diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,8 +1,14 @@ # Revision history for lsp-test -## 0.12.0.0 -- 2021-01-25 +## 0.13.0.0 -- 2021-02-14 -* Add `getIncompleteProgressSessions` to track in ongoing progress sessions (@wz1000) +* Add support for lsp-types-1.1 (@wz1000) +* Automatically respond to `workspace/applyEdit` and + `window/workDoneProgress/create` messages (@wz1000) + +## 0.12.0.0 -- 2021-01-25 +* Add `getIncompleteProgressSessions` to track ongoing progress sessions + (@wz1000) ## 0.11.0.0 -- 2020-05-14 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ lsp-test is a functional testing framework for Language Server Protocol servers. ```haskell -import Language.Haskell.LSP.Test +import Language.LSP.Test main = runSession "hie" fullCaps "proj/dir" $ do doc <- openDoc "Foo.hs" "haskell" skipMany anyNotification diff --git a/lsp-test.cabal b/lsp-test.cabal --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -1,11 +1,11 @@ name: lsp-test -version: 0.12.0.0 +version: 0.13.0.0 synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against . - @Language.Haskell.LSP.Test@ launches your server as a subprocess and allows you to simulate a session - down to the wire, and @Language.Haskell.LSP.Test@ can replay captured sessions from + @Language.LSP.Test@ launches your server as a subprocess and allows you to simulate a session + down to the wire, and @Language.LSP.Test@ can replay captured sessions from . To see examples of it in action, check out , and @@ -22,7 +22,7 @@ cabal-version: 2.0 extra-source-files: README.md , ChangeLog.md -tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1 +tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1, GHC == 8.10.2 source-repository head type: git @@ -35,15 +35,15 @@ library hs-source-dirs: src - exposed-modules: Language.Haskell.LSP.Test - , Language.Haskell.LSP.Test.Replay - reexported-modules: haskell-lsp:Language.Haskell.LSP.Types - , haskell-lsp:Language.Haskell.LSP.Types.Capabilities + exposed-modules: Language.LSP.Test + reexported-modules: lsp-types:Language.LSP.Types + , lsp-types:Language.LSP.Types.Capabilities , parser-combinators:Control.Applicative.Combinators default-language: Haskell2010 build-depends: base >= 4.10 && < 5 - , haskell-lsp >= 0.22 && < 0.24 + , lsp-types == 1.1.* , aeson + , time , aeson-pretty , ansi-terminal , async @@ -63,31 +63,32 @@ , text , transformers , unordered-containers + , some if os(windows) build-depends: Win32 else build-depends: unix - other-modules: Language.Haskell.LSP.Test.Compat - Language.Haskell.LSP.Test.Decoding - Language.Haskell.LSP.Test.Exceptions - Language.Haskell.LSP.Test.Files - Language.Haskell.LSP.Test.Messages - Language.Haskell.LSP.Test.Parsing - Language.Haskell.LSP.Test.Server - Language.Haskell.LSP.Test.Session + other-modules: Language.LSP.Test.Compat + Language.LSP.Test.Decoding + Language.LSP.Test.Exceptions + Language.LSP.Test.Files + Language.LSP.Test.Parsing + Language.LSP.Test.Server + Language.LSP.Test.Session ghc-options: -W executable dummy-server main-is: Main.hs hs-source-dirs: test/dummy-server ghc-options: -W - build-depends: base >= 4.10 && < 5 - , haskell-lsp >= 0.23 && < 0.24 - , data-default + build-depends: base >= 4.11 && < 5 + , lsp == 1.1.* , aeson , unordered-containers , directory , filepath + , unliftio + , mtl default-language: Haskell2010 scope: private if !flag(DummyServer) @@ -101,7 +102,7 @@ build-depends: base >= 4.10 && < 5 , hspec , lens - , haskell-lsp >= 0.22 && < 0.24 + , lsp-types == 1.1.* , lsp-test , data-default , aeson @@ -110,4 +111,4 @@ , directory , filepath default-language: Haskell2010 - build-tool-depends: lsp-test:dummy-server + build-tool-depends: lsp-test:dummy-server diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs deleted file mode 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ /dev/null @@ -1,689 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ExistentialQuantification #-} - -{-| -Module : Language.Haskell.LSP.Test -Description : A functional testing framework for LSP servers. -Maintainer : luke_lau@icloud.com -Stability : experimental -Portability : non-portable - -Provides the framework to start functionally testing -. -You should import "Language.Haskell.LSP.Types" alongside this. --} -module Language.Haskell.LSP.Test - ( - -- * Sessions - Session - , runSession - -- ** Config - , runSessionWithConfig - , SessionConfig(..) - , defaultConfig - , C.fullCaps - -- ** Exceptions - , module Language.Haskell.LSP.Test.Exceptions - , withTimeout - -- * Sending - , request - , request_ - , sendRequest - , sendNotification - , sendResponse - -- * Receving - , module Language.Haskell.LSP.Test.Parsing - -- * Utilities - -- | Quick helper functions for common tasks. - - -- ** Initialization - , initializeResponse - -- ** Documents - , createDoc - , openDoc - , closeDoc - , changeDoc - , documentContents - , getDocumentEdit - , getDocUri - , getVersionedDoc - -- ** Symbols - , getDocumentSymbols - -- ** Diagnostics - , waitForDiagnostics - , waitForDiagnosticsSource - , noDiagnostics - , getCurrentDiagnostics - , getIncompleteProgressSessions - -- ** Commands - , executeCommand - -- ** Code Actions - , getCodeActions - , getAllCodeActions - , executeCodeAction - -- ** Completions - , getCompletions - -- ** References - , getReferences - -- ** Definitions - , getDefinitions - , getTypeDefinitions - -- ** Renaming - , rename - -- ** Hover - , getHover - -- ** Highlights - , getHighlights - -- ** Formatting - , formatDoc - , formatRange - -- ** Edits - , applyEdit - -- ** Code lenses - , getCodeLenses - -- ** Capabilities - , getRegisteredCapabilities - ) where - -import Control.Applicative.Combinators -import Control.Concurrent -import Control.Monad -import Control.Monad.IO.Class -import Control.Exception -import Control.Lens hiding ((.=), List) -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Data.Aeson -import Data.Default -import qualified Data.HashMap.Strict as HashMap -import Data.List -import Data.Maybe -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens hiding - (id, capabilities, message, executeCommand, applyEdit, rename) -import qualified Language.Haskell.LSP.Types.Lens as LSP -import qualified Language.Haskell.LSP.Types.Capabilities as C -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.VFS -import Language.Haskell.LSP.Test.Compat -import Language.Haskell.LSP.Test.Decoding -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 System.FilePath.Glob as Glob - --- | Starts a new session. --- --- > runSession "hie" fullCaps "path/to/root/dir" $ do --- > doc <- openDoc "Desktop/simple.hs" "haskell" --- > diags <- waitForDiagnostics --- > let pos = Position 12 5 --- > params = TextDocumentPositionParams doc --- > hover <- request TextDocumentHover params -runSession :: String -- ^ The command to run the server. - -> 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 -runSession = runSessionWithConfig def - --- | Starts a new sesion with a custom configuration. -runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session. - -> String -- ^ The command to run the server. - -> 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 -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) - Nothing - caps - (Just TraceOff) - Nothing - 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 <- 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) - - case initRspMsg ^. LSP.result of - Left error -> liftIO $ putStrLn ("Error while initializing: " ++ show error) - Right _ -> pure () - - initRspVar <- initRsp <$> ask - liftIO $ putMVar initRspVar initRspMsg - sendNotification Initialized InitializedParams - - case lspConfig config of - 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 - -- | Asks the server to shutdown and exit politely - exitServer :: Session () - exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams - - -- | Listens to the server output until the shutdown ack, - -- makes sure it matches the record and signals any semaphores - listenServer :: Handle -> SessionContext -> IO () - listenServer serverOut context = do - msgBytes <- getNextMessage serverOut - - reqMap <- readMVar $ requestMap context - - let msg = decodeFromServerMsg reqMap msgBytes - writeChan (messageChan context) (ServerMessage msg) - - case msg of - (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 (virtualFileText file) - --- | Parses an ApplyEditRequest, checks that it is for the passed document --- and returns the new content -getDocumentEdit :: TextDocumentIdentifier -> Session T.Text -getDocumentEdit doc = do - req <- message :: Session ApplyWorkspaceEditRequest - - unless (checkDocumentChanges req || checkChanges req) $ - liftIO $ throw (IncorrectApplyEditRequest (show req)) - - documentContents doc - where - checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool - checkDocumentChanges req = - let changes = req ^. params . edit . documentChanges - maybeDocs = fmap (fmap (^. textDocument . uri)) changes - in case maybeDocs of - Just docs -> (doc ^. uri) `elem` docs - Nothing -> False - checkChanges :: ApplyWorkspaceEditRequest -> Bool - checkChanges req = - let mMap = req ^. params . edit . changes - in maybe False (HashMap.member (doc ^. uri)) mMap - --- | Sends a request to the server and waits for its response. --- Will skip any messages in between the request and the response --- @ --- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse --- @ --- Note: will skip any messages in between the request and the response. -request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a) -request m = sendRequest m >=> skipManyTill anyMessage . responseForId - --- | The same as 'sendRequest', but discard the response. -request_ :: ToJSON params => ClientMethod -> params -> Session () -request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value)) - --- | Sends a request to the server. Unlike 'request', this doesn't wait for the response. -sendRequest - :: ToJSON params - => ClientMethod -- ^ The request method. - -> params -- ^ The request parameters. - -> Session LspId -- ^ The id of the request that was sent. -sendRequest method params = do - id <- curReqId <$> get - modify $ \c -> c { curReqId = nextId id } - - let req = RequestMessage' "2.0" id method params - - -- Update the request map - reqMap <- requestMap <$> ask - liftIO $ modifyMVar_ reqMap $ - \r -> return $ updateRequestMap r id method - - sendMessage req - - return id - - where nextId (IdInt i) = IdInt (i + 1) - nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1 - --- | A custom type for request message that doesn't --- need a response type, allows us to infer the request --- message type without using proxies. -data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a - -instance ToJSON a => ToJSON (RequestMessage' a) where - toJSON (RequestMessage' rpc id method params) = - object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params] - - --- | Sends a notification to the server. -sendNotification :: ToJSON a - => ClientMethod -- ^ The notification method. - -> a -- ^ The notification parameters. - -> Session () - --- Open a virtual file if we send a did open text document notification -sendNotification TextDocumentDidOpen params = do - let params' = fromJust $ decode $ encode params - n :: DidOpenTextDocumentNotification - n = NotificationMessage "2.0" TextDocumentDidOpen params' - oldVFS <- vfs <$> get - let (newVFS,_) = openVFS oldVFS n - modify (\s -> s { vfs = newVFS }) - sendMessage n - --- Close a virtual file if we send a close text document notification -sendNotification TextDocumentDidClose params = do - let params' = fromJust $ decode $ encode params - n :: DidCloseTextDocumentNotification - n = NotificationMessage "2.0" TextDocumentDidClose params' - oldVFS <- vfs <$> get - let (newVFS,_) = closeVFS oldVFS n - modify (\s -> s { vfs = newVFS }) - sendMessage n - -sendNotification TextDocumentDidChange params = do - let params' = fromJust $ decode $ encode params - n :: DidChangeTextDocumentNotification - n = NotificationMessage "2.0" TextDocumentDidChange params' - oldVFS <- vfs <$> get - let (newVFS,_) = changeFromClientVFS oldVFS n - modify (\s -> s { vfs = newVFS }) - sendMessage n - -sendNotification method params = sendMessage (NotificationMessage "2.0" method params) - --- | Sends a response to the server. -sendResponse :: ToJSON a => ResponseMessage a -> Session () -sendResponse = sendMessage - --- | Returns the initialize response that was received from the server. --- The initialize requests and responses are not included the session, --- so if you need to test it use this. -initializeResponse :: Session InitializeResponse -initializeResponse = initRsp <$> ask >>= (liftIO . readMVar) - --- | /Creates/ a new text document. This is different from 'openDoc' --- as it sends a workspace/didChangeWatchedFiles notification letting the server --- know that a file was created within the workspace, __provided that the server --- has registered for it__, and the file matches any patterns the server --- registered for. --- It /does not/ actually create a file on disk, but is useful for convincing --- the server that one does exist. --- --- @since 11.0.0.0 -createDoc :: FilePath -- ^ The path to the document to open, __relative to the root directory__. - -> String -- ^ The text document's language identifier, e.g. @"haskell"@. - -> T.Text -- ^ The content of the text document to create. - -> Session TextDocumentIdentifier -- ^ The identifier of the document just created. -createDoc file languageId contents = do - dynCaps <- curDynCaps <$> get - rootDir <- asks rootDir - caps <- asks sessionCapabilities - absFile <- liftIO $ canonicalizePath (rootDir file) - let regs = filter (\r -> r ^. method == WorkspaceDidChangeWatchedFiles) $ - Map.elems dynCaps - watchHits :: FileSystemWatcher -> Bool - watchHits (FileSystemWatcher pattern kind) = - -- If WatchKind is exlcuded, defaults to all true as per spec - fileMatches pattern && createHits (fromMaybe (WatchKind True True True) kind) - - fileMatches pattern = Glob.match (Glob.compile pattern) relOrAbs - -- If the pattern is absolute then match against the absolute fp - where relOrAbs - | isAbsolute pattern = absFile - | otherwise = file - - 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 - - clientCapsSupports = - caps ^? workspace . _Just . didChangeWatchedFiles . _Just . dynamicRegistration . _Just - == Just True - shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs - - when shouldSend $ - sendNotification WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [ FileEvent (filePathToUri (rootDir file)) FcCreated ] - openDoc' file languageId contents - --- | Opens a text document that /exists on disk/, and sends a --- textDocument/didOpen notification to the server. -openDoc :: FilePath -> String -> Session TextDocumentIdentifier -openDoc file languageId = do - context <- ask - let fp = rootDir context file - contents <- liftIO $ T.readFile fp - openDoc' file languageId contents - --- | This is a variant of `openDoc` that takes the file content as an argument. --- Use this is the file exists /outside/ of the current workspace. -openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier -openDoc' file languageId contents = do - context <- ask - let fp = rootDir context file - uri = filePathToUri fp - item = TextDocumentItem uri (T.pack languageId) 0 contents - sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item) - pure $ TextDocumentIdentifier uri - --- | Closes a text document and sends a textDocument/didOpen notification to the server. -closeDoc :: TextDocumentIdentifier -> Session () -closeDoc docId = do - let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri)) - sendNotification TextDocumentDidClose params - --- | Changes a text document and sends a textDocument/didOpen notification to the server. -changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session () -changeDoc docId changes = do - verDoc <- getVersionedDoc docId - let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes) - sendNotification TextDocumentDidChange params - --- | Gets the Uri for the file corrected to the session directory. -getDocUri :: FilePath -> Session Uri -getDocUri file = do - context <- ask - 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 message :: Session PublishDiagnosticsNotification - let (List diags) = diagsNot ^. params . LSP.diagnostics - return diags - --- | The same as 'waitForDiagnostics', but will only match a specific --- 'Language.Haskell.LSP.Types._source'. -waitForDiagnosticsSource :: String -> Session [Diagnostic] -waitForDiagnosticsSource src = do - diags <- waitForDiagnostics - let res = filter matches diags - if null res - then waitForDiagnosticsSource src - else return res - where - matches :: Diagnostic -> Bool - matches d = d ^. source == Just (T.pack src) - --- | Expects a 'PublishDiagnosticsNotification' and throws an --- 'UnexpectedDiagnostics' exception if there are any diagnostics --- returned. -noDiagnostics :: Session () -noDiagnostics = do - diagsNot <- message :: Session PublishDiagnosticsNotification - when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics - --- | Returns the symbols in a document. -getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation]) -getDocumentSymbols doc = do - 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] -getCodeActions doc range = do - ctx <- getCodeActionContext doc - rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx Nothing) - - case rsp ^. result of - 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 --- diagnostics' positions. -getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult] -getAllCodeActions doc = do - ctx <- getCodeActionContext doc - - foldM (go ctx) [] =<< getCurrentDiagnostics doc - - where - go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult] - go ctx acc diag = do - ResponseMessage _ rspLid res <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing) - - case res of - Left e -> throw (UnexpectedResponseError rspLid e) - Right (List cmdOrCAs) -> pure (acc ++ cmdOrCAs) - -getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext -getCodeActionContext doc = do - curDiags <- getCurrentDiagnostics doc - return $ CodeActionContext (List curDiags) Nothing - --- | Returns the current diagnostics that have been sent to the client. --- Note that this does not wait for more to come in. -getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic] -getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. uri) . curDiagnostics <$> get - --- | Returns the tokens of all progress sessions that have started but not yet ended. -getIncompleteProgressSessions :: Session (Set.Set ProgressToken) -getIncompleteProgressSessions = curProgressSessions <$> get - --- | Executes a command. -executeCommand :: Command -> Session () -executeCommand cmd = do - let args = decode $ encode $ fromJust $ cmd ^. arguments - execParams = ExecuteCommandParams (cmd ^. command) args Nothing - request_ 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 - maybe (return ()) executeCommand $ action ^. command - - 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 updateState (ReqApplyWorkspaceEdit req) - --- | Adds the current version to the document, as tracked by the session. -getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier -getVersionedDoc (TextDocumentIdentifier uri) = do - fs <- vfsMap . vfs <$> get - let ver = - case fs Map.!? toNormalizedUri uri of - Just vf -> Just (virtualFileVersion vf) - _ -> 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 sessionCapabilities - - let supportsDocChanges = fromMaybe False $ do - let mWorkspace = C._workspace caps - C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace - C.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 <- request TextDocumentCompletion (TextDocumentPositionParams doc pos Nothing) - - case getResponseResult rsp of - Completions (List items) -> return items - CompletionList (CompletionListType _ (List items)) -> return items - --- | Returns the references for the position in the document. -getReferences :: TextDocumentIdentifier -- ^ The document to lookup in. - -> Position -- ^ The position to lookup. - -> Bool -- ^ Whether to include declarations as references. - -> Session [Location] -- ^ The locations of the references. -getReferences doc pos inclDecl = - let ctx = ReferenceContext inclDecl - params = ReferenceParams doc pos ctx Nothing - in getResponseResult <$> request TextDocumentReferences params - --- | 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 TextDocumentDefinition params :: Session DefinitionResponse - case getResponseResult rsp of - SingleLoc loc -> pure [loc] - MultiLoc locs -> pure locs - --- | 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 TextDocumentTypeDefinition params :: Session TypeDefinitionResponse - case getResponseResult rsp of - SingleLoc loc -> pure [loc] - MultiLoc locs -> pure locs - --- | 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 - rsp <- request TextDocumentRename params :: Session RenameResponse - let wEdit = getResponseResult rsp - req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) - updateState (ReqApplyWorkspaceEdit req) - --- | Returns the hover information at the specified position. -getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover) -getHover doc pos = - let params = TextDocumentPositionParams doc pos Nothing - in getResponseResult <$> request TextDocumentHover params - --- | Returns the highlighted occurences of the term at the specified position -getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight] -getHighlights doc pos = - let params = TextDocumentPositionParams doc pos Nothing - in getResponseResult <$> request TextDocumentDocumentHighlight params - --- | Checks the response for errors and throws an exception if needed. --- Returns the result if successful. -getResponseResult :: ResponseMessage a -> a -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 () -formatDoc doc opts = do - let params = DocumentFormattingParams doc opts Nothing - edits <- getResponseResult <$> request TextDocumentFormatting 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 - edits <- getResponseResult <$> request TextDocumentRangeFormatting params - applyTextEdits doc edits - -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) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) - in updateState (ReqApplyWorkspaceEdit req) - --- | Returns the code lenses for the specified document. -getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] -getCodeLenses tId = do - rsp <- request TextDocumentCodeLens (CodeLensParams tId Nothing) :: Session CodeLensResponse - case getResponseResult rsp of - List res -> pure res - --- | Returns a list of capabilities that the server has requested to /dynamically/ --- register during the 'Session'. --- --- @since 0.11.0.0 -getRegisteredCapabilities :: Session [Registration] -getRegisteredCapabilities = (Map.elems . curDynCaps) <$> get diff --git a/src/Language/Haskell/LSP/Test/Compat.hs b/src/Language/Haskell/LSP/Test/Compat.hs deleted file mode 100644 --- a/src/Language/Haskell/LSP/Test/Compat.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE CPP #-} --- For some reason ghc warns about not using --- Control.Monad.IO.Class but it's needed for --- MonadIO -{-# OPTIONS_GHC -Wunused-imports #-} -module Language.Haskell.LSP.Test.Compat where - -import Data.Maybe -import System.IO - -#if MIN_VERSION_process(1,6,3) --- We have to hide cleanupProcess for process-1.6.3.0 --- cause it is in the public api for 1.6.3.0 versions --- shipped with ghc >= 8.6 and < 8.6.4 -import System.Process hiding (getPid, cleanupProcess, withCreateProcess) -# if MIN_VERSION_process(1,6,4) -import qualified System.Process (getPid, cleanupProcess, withCreateProcess) -# else -import Foreign.C.Error -import GHC.IO.Exception ( IOErrorType(..), IOException(..) ) - -import qualified System.Process (getPid) -import qualified Control.Exception as C -# endif -#else -import Control.Concurrent.MVar -import Foreign.C.Error -import GHC.IO.Exception ( IOErrorType(..), IOException(..) ) -import System.Process hiding (withCreateProcess) -import System.Process.Internals - -import qualified Control.Exception as C -#endif - -#ifdef mingw32_HOST_OS -import qualified System.Win32.Process -#else -import qualified System.Posix.Process -#endif - - -getCurrentProcessID :: IO Int -#ifdef mingw32_HOST_OS -getCurrentProcessID = fromIntegral <$> System.Win32.Process.getCurrentProcessId -#else -getCurrentProcessID = fromIntegral <$> System.Posix.Process.getProcessID -#endif - -getProcessID :: ProcessHandle -> IO Int -getProcessID p = fromIntegral . fromJust <$> getProcessID' p - where -#if MIN_VERSION_process(1,6,3) - getProcessID' = System.Process.getPid -#else -#if MIN_VERSION_process(1,6,0) - getProcessID' (ProcessHandle mh _ _) = do -#else - getProcessID' (ProcessHandle mh _) = do -#endif - p_ <- readMVar mh - case p_ of -#ifdef mingw32_HOST_OS - OpenHandle h -> do - pid <- System.Win32.Process.getProcessId h - return $ Just pid -#else - OpenHandle pid -> return $ Just pid -#endif - _ -> return Nothing -#endif - -cleanupProcess - :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () - -withCreateProcess - :: CreateProcess - -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) - -> IO a - -#if MIN_VERSION_process(1,6,4) - -cleanupProcess = System.Process.cleanupProcess - -withCreateProcess = System.Process.withCreateProcess - -#else - -cleanupProcess (mb_stdin, mb_stdout, mb_stderr, ph) = do - -- We ignore the spurious "permission denied" error in windows: - -- see https://github.com/haskell/process/issues/110 - ignorePermDenied $ terminateProcess ph - -- Note, it's important that other threads that might be reading/writing - -- these handles also get killed off, since otherwise they might be holding - -- the handle lock and prevent us from closing, leading to deadlock. - maybe (return ()) (ignoreSigPipe . hClose) mb_stdin - maybe (return ()) hClose mb_stdout - maybe (return ()) hClose mb_stderr - - return () - where ignoreSigPipe = ignoreIOError ResourceVanished ePIPE - ignorePermDenied = ignoreIOError PermissionDenied eACCES - -ignoreIOError :: IOErrorType -> Errno -> IO () -> IO () -ignoreIOError ioErrorType errno = - C.handle $ \e -> case e of - IOError { ioe_type = iot - , ioe_errno = Just ioe } - | iot == ioErrorType && Errno ioe == errno -> return () - _ -> C.throwIO e - -withCreateProcess c action = - C.bracket (createProcess c) cleanupProcess - (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) - -#endif diff --git a/src/Language/Haskell/LSP/Test/Decoding.hs b/src/Language/Haskell/LSP/Test/Decoding.hs deleted file mode 100644 --- a/src/Language/Haskell/LSP/Test/Decoding.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Language.Haskell.LSP.Test.Decoding where - -import Prelude hiding ( id ) -import Data.Aeson -import Data.Foldable -import Control.Exception -import Control.Lens -import qualified Data.ByteString.Lazy.Char8 as B -import Data.Maybe -import System.IO -import System.IO.Error -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Test.Exceptions -import qualified Data.HashMap.Strict as HM - -getAllMessages :: Handle -> IO [B.ByteString] -getAllMessages h = do - done <- hIsEOF h - if done - then return [] - else do - msg <- getNextMessage h - - (msg :) <$> getAllMessages h - --- | Fetches the next message bytes based on --- the Content-Length header -getNextMessage :: Handle -> IO B.ByteString -getNextMessage h = do - headers <- getHeaders h - case read . init <$> lookup "Content-Length" headers of - Nothing -> throw NoContentLengthHeader - Just size -> B.hGet h size - -addHeader :: B.ByteString -> B.ByteString -addHeader content = B.concat - [ "Content-Length: " - , B.pack $ show $ B.length content - , "\r\n" - , "\r\n" - , content - ] - -getHeaders :: Handle -> IO [(String, String)] -getHeaders h = do - l <- catch (hGetLine h) eofHandler - let (name, val) = span (/= ':') l - if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h - where eofHandler e - | isEOFError e = throw UnexpectedServerTermination - | otherwise = throw e - -type RequestMap = HM.HashMap LspId ClientMethod - -newRequestMap :: RequestMap -newRequestMap = HM.empty - -updateRequestMap :: RequestMap -> LspId -> ClientMethod -> RequestMap -updateRequestMap reqMap id method = HM.insert id method reqMap - -getRequestMap :: [FromClientMessage] -> RequestMap -getRequestMap = foldl helper HM.empty - where - helper acc msg = case msg of - (ReqInitialize val) -> insert val acc - (ReqShutdown val) -> insert val acc - (ReqHover val) -> insert val acc - (ReqCompletion val) -> insert val acc - (ReqCompletionItemResolve val) -> insert val acc - (ReqSignatureHelp val) -> insert val acc - (ReqDefinition val) -> insert val acc - (ReqTypeDefinition val) -> insert val acc - (ReqFindReferences val) -> insert val acc - (ReqDocumentHighlights val) -> insert val acc - (ReqDocumentSymbols val) -> insert val acc - (ReqWorkspaceSymbols val) -> insert val acc - (ReqCodeAction val) -> insert val acc - (ReqCodeLens val) -> insert val acc - (ReqCodeLensResolve val) -> insert val acc - (ReqDocumentFormatting val) -> insert val acc - (ReqDocumentRangeFormatting val) -> insert val acc - (ReqDocumentOnTypeFormatting val) -> insert val acc - (ReqRename val) -> insert val acc - (ReqExecuteCommand val) -> insert val acc - (ReqDocumentLink val) -> insert val acc - (ReqDocumentLinkResolve val) -> insert val acc - (ReqWillSaveWaitUntil val) -> insert val acc - _ -> acc - insert m = HM.insert (m ^. id) (m ^. method) - -matchResponseMsgType :: ClientMethod -> B.ByteString -> FromServerMessage -matchResponseMsgType req = case req of - Initialize -> RspInitialize . decoded - Shutdown -> RspShutdown . decoded - TextDocumentHover -> RspHover . decoded - TextDocumentCompletion -> RspCompletion . decoded - CompletionItemResolve -> RspCompletionItemResolve . decoded - TextDocumentSignatureHelp -> RspSignatureHelp . decoded - TextDocumentDefinition -> RspDefinition . decoded - TextDocumentTypeDefinition -> RspTypeDefinition . decoded - TextDocumentReferences -> RspFindReferences . decoded - TextDocumentDocumentHighlight -> RspDocumentHighlights . decoded - TextDocumentDocumentSymbol -> RspDocumentSymbols . decoded - WorkspaceSymbol -> RspWorkspaceSymbols . decoded - TextDocumentCodeAction -> RspCodeAction . decoded - TextDocumentCodeLens -> RspCodeLens . decoded - CodeLensResolve -> RspCodeLensResolve . decoded - TextDocumentFormatting -> RspDocumentFormatting . decoded - TextDocumentRangeFormatting -> RspDocumentRangeFormatting . decoded - TextDocumentOnTypeFormatting -> RspDocumentOnTypeFormatting . decoded - TextDocumentRename -> RspRename . decoded - WorkspaceExecuteCommand -> RspExecuteCommand . decoded - TextDocumentDocumentLink -> RspDocumentLink . decoded - DocumentLinkResolve -> RspDocumentLinkResolve . decoded - TextDocumentWillSaveWaitUntil -> RspWillSaveWaitUntil . decoded - CustomClientMethod{} -> RspCustomServer . decoded - x -> error . ((show x ++ " is not a request: ") ++) . show - where decoded x = fromMaybe (error $ "Couldn't decode response for the request type: " - ++ show req ++ "\n" ++ show x) - (decode x) - -decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage -decodeFromServerMsg reqMap bytes = - case HM.lookup "method" obj of - Just methodStr -> case fromJSON methodStr of - Success method -> case method of - -- We can work out the type of the message - TextDocumentPublishDiagnostics -> NotPublishDiagnostics $ fromJust $ decode bytes - WindowShowMessage -> NotShowMessage $ fromJust $ decode bytes - WindowLogMessage -> NotLogMessage $ fromJust $ decode bytes - CancelRequestServer -> NotCancelRequestFromServer $ fromJust $ decode bytes - Progress -> - fromJust $ asum [NotWorkDoneProgressBegin <$> decode bytes, NotWorkDoneProgressReport <$> decode bytes, NotWorkDoneProgressEnd <$> decode bytes] - WindowWorkDoneProgressCreate -> ReqWorkDoneProgressCreate $ fromJust $ decode bytes - TelemetryEvent -> NotTelemetry $ fromJust $ decode bytes - WindowShowMessageRequest -> ReqShowMessage $ fromJust $ decode bytes - ClientRegisterCapability -> ReqRegisterCapability $ fromJust $ decode bytes - ClientUnregisterCapability -> ReqUnregisterCapability $ fromJust $ decode bytes - WorkspaceApplyEdit -> ReqApplyWorkspaceEdit $ fromJust $ decode bytes - WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet" - WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet" - CustomServerMethod _ - | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes - | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes - | otherwise -> NotCustomServer $ fromJust $ decode bytes - - Error e -> error e - - Nothing -> case decode bytes :: Maybe (ResponseMessage Value) of - Just msg -> case HM.lookup (requestId $ msg ^. id) reqMap of - Just req -> matchResponseMsgType req bytes -- try to decode it to more specific type - Nothing -> error "Couldn't match up response with request" - Nothing -> error "Couldn't decode message" - where obj = fromJust $ decode bytes :: Object diff --git a/src/Language/Haskell/LSP/Test/Exceptions.hs b/src/Language/Haskell/LSP/Test/Exceptions.hs deleted file mode 100644 --- a/src/Language/Haskell/LSP/Test/Exceptions.hs +++ /dev/null @@ -1,60 +0,0 @@ -module Language.Haskell.LSP.Test.Exceptions where - -import Control.Exception -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types -import Data.Aeson -import Data.Aeson.Encode.Pretty -import Data.Algorithm.Diff -import Data.Algorithm.DiffOutput -import Data.List -import qualified Data.ByteString.Lazy.Char8 as B - --- | An exception that can be thrown during a 'Haskell.LSP.Test.Session.Session' -data SessionException = Timeout (Maybe FromServerMessage) - | NoContentLengthHeader - | UnexpectedMessage String FromServerMessage - | ReplayOutOfOrder FromServerMessage [FromServerMessage] - | UnexpectedDiagnostics - | IncorrectApplyEditRequest String - | UnexpectedResponseError LspIdRsp ResponseError - | UnexpectedServerTermination - | IllegalInitSequenceMessage FromServerMessage - deriving Eq - -instance Exception SessionException - -instance Show SessionException where - show (Timeout lastMsg) = - "Timed out waiting to receive a message from the server." ++ - case lastMsg of - Just msg -> "\nLast message received:\n" ++ B.unpack (encodePretty msg) - Nothing -> mempty - show NoContentLengthHeader = "Couldn't read Content-Length header from the server." - show (UnexpectedMessage expected lastMsg) = - "Received an unexpected message from the server:\n" ++ - "Was parsing: " ++ expected ++ "\n" ++ - "Last message received:\n" ++ B.unpack (encodePretty lastMsg) - show (ReplayOutOfOrder received expected) = - let expected' = nub expected - getJsonDiff = lines . B.unpack . encodePretty - showExp exp = B.unpack (encodePretty exp) ++ "\nDiff:\n" ++ - ppDiff (getGroupedDiff (getJsonDiff received) (getJsonDiff exp)) - in "Replay is out of order:\n" ++ - -- Print json so its a bit easier to update the session logs - "Received from server:\n" ++ B.unpack (encodePretty received) ++ "\n" ++ - "Raw from server:\n" ++ B.unpack (encode received) ++ "\n" ++ - "Expected one of:\n" ++ unlines (map showExp expected') - show UnexpectedDiagnostics = "Unexpectedly received diagnostics from the server." - show (IncorrectApplyEditRequest msgStr) = "ApplyEditRequest didn't contain document, instead received:\n" - ++ msgStr - show (UnexpectedResponseError lid e) = "Received an exepected error in a response for id " ++ show lid ++ ":\n" - ++ show e - show UnexpectedServerTermination = "Language server unexpectedly terminated" - show (IllegalInitSequenceMessage msg) = - "Received an illegal message between the initialize request and response:\n" - ++ B.unpack (encodePretty msg) - --- | A predicate that matches on any 'SessionException' -anySessionException :: SessionException -> Bool -anySessionException = const True diff --git a/src/Language/Haskell/LSP/Test/Files.hs b/src/Language/Haskell/LSP/Test/Files.hs deleted file mode 100644 --- a/src/Language/Haskell/LSP/Test/Files.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -module Language.Haskell.LSP.Test.Files - ( swapFiles - , rootDir - ) -where - -import Language.Haskell.LSP.Capture -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens -import Language.Haskell.LSP.Messages -import Control.Lens -import qualified Data.HashMap.Strict as HM -import qualified Data.Text as T -import Data.Maybe -import System.Directory -import System.FilePath - -swapFiles :: FilePath -> [Event] -> IO [Event] -swapFiles relCurBaseDir msgs = do - let capturedBaseDir = rootDir msgs - - curBaseDir <- ( relCurBaseDir) <$> getCurrentDirectory - let transform uri = - let fp = fromMaybe (error "Couldn't transform uri") (uriToFilePath uri) - newFp = curBaseDir makeRelative capturedBaseDir fp - in filePathToUri newFp - newMsgs = map (mapUris transform) msgs - - return newMsgs - -rootDir :: [Event] -> FilePath -rootDir (FromClient _ (ReqInitialize req):_) = - fromMaybe (error "Couldn't find root dir") $ do - rootUri <- req ^. params .rootUri - uriToFilePath rootUri -rootDir _ = error "Couldn't find initialize request in session" - -mapUris :: (Uri -> Uri) -> Event -> Event -mapUris f event = - case event of - FromClient t msg -> FromClient t (fromClientMsg msg) - FromServer t msg -> FromServer t (fromServerMsg msg) - - where - --TODO: Handle all other URIs that might need swapped - fromClientMsg (NotDidOpenTextDocument n) = NotDidOpenTextDocument $ swapUri (params . textDocument) n - fromClientMsg (NotDidChangeTextDocument n) = NotDidChangeTextDocument $ swapUri (params . textDocument) n - fromClientMsg (NotWillSaveTextDocument n) = NotWillSaveTextDocument $ swapUri (params . textDocument) n - fromClientMsg (NotDidSaveTextDocument n) = NotDidSaveTextDocument $ swapUri (params . textDocument) n - fromClientMsg (NotDidCloseTextDocument n) = NotDidCloseTextDocument $ swapUri (params . textDocument) n - fromClientMsg (ReqInitialize r) = ReqInitialize $ params .~ transformInit (r ^. params) $ r - fromClientMsg (ReqDocumentSymbols r) = ReqDocumentSymbols $ swapUri (params . textDocument) r - fromClientMsg (ReqRename r) = ReqRename $ swapUri (params . textDocument) r - fromClientMsg x = x - - fromServerMsg :: FromServerMessage -> FromServerMessage - fromServerMsg (ReqApplyWorkspaceEdit r) = - ReqApplyWorkspaceEdit $ params . edit .~ swapWorkspaceEdit (r ^. params . edit) $ r - - fromServerMsg (NotPublishDiagnostics n) = NotPublishDiagnostics $ swapUri params n - - fromServerMsg (RspDocumentSymbols r) = - let swapUri' (DSSymbolInformation si) = DSSymbolInformation (swapUri location <$> si) - swapUri' (DSDocumentSymbols dss) = DSDocumentSymbols dss -- no file locations here - in RspDocumentSymbols $ r & result %~ (fmap swapUri') - - fromServerMsg (RspRename r) = RspRename $ r & result %~ (fmap swapWorkspaceEdit) - - fromServerMsg x = x - - swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit - swapWorkspaceEdit e = - let newDocChanges = fmap (fmap (swapUri textDocument)) $ e ^. documentChanges - newChanges = fmap (swapKeys f) $ e ^. changes - in WorkspaceEdit newChanges newDocChanges - - swapKeys :: (Uri -> Uri) -> HM.HashMap Uri b -> HM.HashMap Uri b - swapKeys f = HM.foldlWithKey' (\acc k v -> HM.insert (f k) v acc) HM.empty - - swapUri :: HasUri b Uri => Lens' a b -> a -> a - swapUri lens x = - let newUri = f (x ^. lens . uri) - in (lens . uri) .~ newUri $ x - - -- | Transforms rootUri/rootPath. - transformInit :: InitializeParams -> InitializeParams - transformInit x = - let newRootUri = fmap f (x ^. rootUri) - newRootPath = do - fp <- T.unpack <$> x ^. rootPath - let uri = filePathToUri fp - T.pack <$> uriToFilePath (f uri) - in (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x diff --git a/src/Language/Haskell/LSP/Test/Messages.hs b/src/Language/Haskell/LSP/Test/Messages.hs deleted file mode 100644 --- a/src/Language/Haskell/LSP/Test/Messages.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -module Language.Haskell.LSP.Test.Messages where - -import Data.Aeson -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types - -isServerResponse :: FromServerMessage -> Bool -isServerResponse (RspInitialize _) = True -isServerResponse (RspShutdown _) = True -isServerResponse (RspHover _) = True -isServerResponse (RspCompletion _) = True -isServerResponse (RspCompletionItemResolve _) = True -isServerResponse (RspSignatureHelp _) = True -isServerResponse (RspDefinition _) = True -isServerResponse (RspTypeDefinition _) = True -isServerResponse (RspFindReferences _) = True -isServerResponse (RspDocumentHighlights _) = True -isServerResponse (RspDocumentSymbols _) = True -isServerResponse (RspWorkspaceSymbols _) = True -isServerResponse (RspCodeAction _) = True -isServerResponse (RspCodeLens _) = True -isServerResponse (RspCodeLensResolve _) = True -isServerResponse (RspDocumentFormatting _) = True -isServerResponse (RspDocumentRangeFormatting _) = True -isServerResponse (RspDocumentOnTypeFormatting _) = True -isServerResponse (RspRename _) = True -isServerResponse (RspExecuteCommand _) = True -isServerResponse (RspError _) = True -isServerResponse (RspDocumentLink _) = True -isServerResponse (RspDocumentLinkResolve _) = True -isServerResponse (RspWillSaveWaitUntil _) = True -isServerResponse _ = False - -isServerRequest :: FromServerMessage -> Bool -isServerRequest (ReqRegisterCapability _) = True -isServerRequest (ReqApplyWorkspaceEdit _) = True -isServerRequest (ReqShowMessage _) = True -isServerRequest (ReqUnregisterCapability _) = True -isServerRequest _ = False - -isServerNotification :: FromServerMessage -> Bool -isServerNotification (NotPublishDiagnostics _) = True -isServerNotification (NotLogMessage _) = True -isServerNotification (NotShowMessage _) = True -isServerNotification (NotTelemetry _) = True -isServerNotification (NotCancelRequestFromServer _) = True -isServerNotification _ = False - -handleServerMessage - :: forall a. - (forall b c. RequestMessage ServerMethod b c -> a) - -> (forall d. ResponseMessage d -> a) - -> (forall e. NotificationMessage ServerMethod e -> a) - -> FromServerMessage - -> a -handleServerMessage request response notification msg = case msg of - (ReqRegisterCapability m) -> request m - (ReqApplyWorkspaceEdit m) -> request m - (ReqShowMessage m) -> request m - (ReqUnregisterCapability m) -> request m - (ReqCustomServer m) -> request m - (ReqWorkDoneProgressCreate m) -> request m - (RspInitialize m) -> response m - (RspShutdown m) -> response m - (RspHover m) -> response m - (RspCompletion m) -> response m - (RspCompletionItemResolve m) -> response m - (RspSignatureHelp m) -> response m - (RspDefinition m) -> response m - (RspFindReferences m) -> response m - (RspDocumentHighlights m) -> response m - (RspDocumentSymbols m) -> response m - (RspWorkspaceSymbols m) -> response m - (RspCodeAction m) -> response m - (RspCodeLens m) -> response m - (RspCodeLensResolve m) -> response m - (RspDocumentFormatting m) -> response m - (RspDocumentRangeFormatting m) -> response m - (RspDocumentOnTypeFormatting m) -> response m - (RspRename m) -> response m - (RspExecuteCommand m) -> response m - (RspError m) -> response m - (RspDocumentLink m) -> response m - (RspDocumentLinkResolve m) -> response m - (RspWillSaveWaitUntil m) -> response m - (RspTypeDefinition m) -> response m - (RspImplementation m) -> response m - (RspDocumentColor m) -> response m - (RspColorPresentation m) -> response m - (RspFoldingRange m) -> response m - (RspCustomServer m) -> response m - (NotPublishDiagnostics m) -> notification m - (NotLogMessage m) -> notification m - (NotShowMessage m) -> notification m - (NotWorkDoneProgressBegin m) -> notification m - (NotWorkDoneProgressReport m) -> notification m - (NotWorkDoneProgressEnd m) -> notification m - (NotTelemetry m) -> notification m - (NotCancelRequestFromServer m) -> notification m - (NotCustomServer m) -> notification m - -handleClientMessage - :: forall a. - (forall b c . (ToJSON b, ToJSON c) => RequestMessage ClientMethod b c -> a) - -> (forall d . ToJSON d => ResponseMessage d -> a) - -> (forall e . ToJSON e => NotificationMessage ClientMethod e -> a) - -> FromClientMessage - -> a -handleClientMessage request response notification msg = case msg of - (ReqInitialize m) -> request m - (ReqShutdown m) -> request m - (ReqHover m) -> request m - (ReqCompletion m) -> request m - (ReqCompletionItemResolve m) -> request m - (ReqSignatureHelp m) -> request m - (ReqDefinition m) -> request m - (ReqFindReferences m) -> request m - (ReqDocumentHighlights m) -> request m - (ReqDocumentSymbols m) -> request m - (ReqWorkspaceSymbols m) -> request m - (ReqCodeAction m) -> request m - (ReqCodeLens m) -> request m - (ReqCodeLensResolve m) -> request m - (ReqDocumentFormatting m) -> request m - (ReqDocumentRangeFormatting m) -> request m - (ReqDocumentOnTypeFormatting m) -> request m - (ReqPrepareRename m) -> request m - (ReqRename m) -> request m - (ReqExecuteCommand m) -> request m - (ReqDocumentLink m) -> request m - (ReqDocumentLinkResolve m) -> request m - (ReqWillSaveWaitUntil m) -> request m - (ReqImplementation m) -> request m - (ReqTypeDefinition m) -> request m - (ReqDocumentColor m) -> request m - (ReqColorPresentation m) -> request m - (ReqFoldingRange m) -> request m - (RspApplyWorkspaceEdit m) -> response m - (RspFromClient m) -> response m - (NotInitialized m) -> notification m - (NotExit m) -> notification m - (NotCancelRequestFromClient m) -> notification m - (NotDidChangeConfiguration m) -> notification m - (NotDidOpenTextDocument m) -> notification m - (NotDidChangeTextDocument m) -> notification m - (NotDidCloseTextDocument m) -> notification m - (NotWillSaveTextDocument m) -> notification m - (NotDidSaveTextDocument m) -> notification m - (NotDidChangeWatchedFiles m) -> notification m - (NotDidChangeWorkspaceFolders m) -> notification m - (NotWorkDoneProgressCancel m) -> notification m - (ReqCustomClient m) -> request m - (NotCustomClient m) -> notification m diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs deleted file mode 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.Haskell.LSP.Test.Parsing - ( -- $receiving - satisfy - , satisfyMaybe - , message - , anyRequest - , anyResponse - , anyNotification - , anyMessage - , loggingNotification - , publishDiagnosticsNotification - , responseForId - ) where - -import Control.Applicative -import Control.Concurrent -import Control.Lens -import Control.Monad.IO.Class -import Control.Monad -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as B -import Data.Conduit.Parser hiding (named) -import qualified Data.Conduit.Parser (named) -import qualified Data.Text as T -import Data.Typeable -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types.Lens as LSP -import Language.Haskell.LSP.Test.Messages -import Language.Haskell.LSP.Test.Session - --- $receiving --- To receive a message, just specify the type that expect: --- --- @ --- msg1 <- message :: Session ApplyWorkspaceEditRequest --- msg2 <- message :: Session HoverResponse --- @ --- --- 'Language.Haskell.LSP.Test.Session' is actually just a parser --- that operates on messages under the hood. This means that you --- can create and combine parsers to match speicifc sequences of --- messages that you expect. --- --- For example, if you wanted to match either a definition or --- references request: --- --- > defOrImpl = (message :: Session DefinitionRequest) --- > <|> (message :: Session ReferencesRequest) --- --- If you wanted to match any number of telemetry --- notifications immediately followed by a response: --- --- @ --- logThenDiags = --- skipManyTill (message :: Session TelemetryNotification) --- anyResponse --- @ - --- | Consumes and returns the next message, if it satisfies the specified predicate. --- --- @since 0.5.2.0 -satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage -satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing) - --- | Consumes and returns the result of the specified predicate if it returns `Just`. --- --- @since 0.6.1.0 -satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a -satisfyMaybe pred = do - - skipTimeout <- overridingTimeout <$> get - timeoutId <- getCurTimeoutId - unless skipTimeout $ do - chan <- asks messageChan - timeout <- asks (messageTimeout . config) - void $ liftIO $ forkIO $ do - threadDelay (timeout * 1000000) - writeChan chan (TimeoutMessage timeoutId) - - x <- Session await - - unless skipTimeout (bumpTimeoutId timeoutId) - - modify $ \s -> s { lastReceivedMessage = Just x } - - case pred x of - Just a -> do - logMsg LogServer x - return a - Nothing -> empty - -named :: T.Text -> Session a -> Session a -named s (Session x) = Session (Data.Conduit.Parser.named s x) - --- | Matches a message of type @a@. -message :: forall a. (Typeable a, FromJSON a) => Session a -message = - let parser = decode . encodeMsg :: FromServerMessage -> Maybe a - in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $ - satisfyMaybe parser - --- | Matches if the message is a notification. -anyNotification :: Session FromServerMessage -anyNotification = named "Any notification" $ satisfy isServerNotification - --- | Matches if the message is a request. -anyRequest :: Session FromServerMessage -anyRequest = named "Any request" $ satisfy isServerRequest - --- | Matches if the message is a response. -anyResponse :: Session FromServerMessage -anyResponse = named "Any response" $ satisfy isServerResponse - --- | Matches a response for a specific id. -responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a) -responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do - let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a) - satisfyMaybe $ \msg -> do - z <- parser msg - guard (z ^. LSP.id == responseId lid) - pure z - --- | Matches any type of message. -anyMessage :: Session FromServerMessage -anyMessage = satisfy (const True) - --- | A version of encode that encodes FromServerMessages as if they --- weren't wrapped. -encodeMsg :: FromServerMessage -> B.ByteString -encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue }) - --- | Matches if the message is a log message notification or a show message notification/request. -loggingNotification :: Session FromServerMessage -loggingNotification = named "Logging notification" $ satisfy shouldSkip - where - shouldSkip (NotLogMessage _) = True - shouldSkip (NotShowMessage _) = True - shouldSkip (ReqShowMessage _) = True - shouldSkip _ = False - --- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification' --- (textDocument/publishDiagnostics) notification. -publishDiagnosticsNotification :: Session PublishDiagnosticsNotification -publishDiagnosticsNotification = named "Publish diagnostics notification" $ - satisfyMaybe $ \msg -> case msg of - NotPublishDiagnostics diags -> Just diags - _ -> Nothing diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs deleted file mode 100644 --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ /dev/null @@ -1,237 +0,0 @@ --- | A testing tool for replaying captured client logs back to a server, --- and validating that the server output matches up with another log. -module Language.Haskell.LSP.Test.Replay - ( replaySession - ) -where - -import Prelude hiding (id) -import Control.Concurrent -import Control.Monad.IO.Class -import qualified Data.ByteString.Lazy.Char8 as B -import qualified Data.Text as T -import Language.Haskell.LSP.Capture -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens as LSP -import Data.Aeson -import Data.Default -import Data.List -import Data.Maybe -import Control.Lens hiding (List) -import Control.Monad -import System.FilePath -import System.IO -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Test.Compat -import Language.Haskell.LSP.Test.Files -import Language.Haskell.LSP.Test.Decoding -import Language.Haskell.LSP.Test.Messages -import Language.Haskell.LSP.Test.Server -import Language.Haskell.LSP.Test.Session - --- | Replays a captured client output and --- makes sure it matches up with an expected response. --- The session directory should have a captured session file in it --- named "session.log". --- You can get these capture files from 'Language.Haskell.LSP.resCaptureFile' in --- haskell-lsp. -replaySession :: String -- ^ The command to run the server. - -> FilePath -- ^ The recorded session directory. - -> IO () -replaySession serverExe sessionDir = do - - entries <- B.lines <$> B.readFile (sessionDir "session.log") - - -- decode session - let unswappedEvents = map (fromJust . decode) entries - - withServer serverExe False $ \serverIn serverOut serverProc -> do - - pid <- getProcessID serverProc - events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents - - let clientEvents = filter isClientMsg events - serverEvents = filter isServerMsg events - clientMsgs = map (\(FromClient _ msg) -> msg) clientEvents - serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents - requestMap = getRequestMap clientMsgs - - reqSema <- newEmptyMVar - rspSema <- newEmptyMVar - passSema <- newEmptyMVar - mainThread <- myThreadId - - sessionThread <- liftIO $ forkIO $ - runSessionWithHandles serverIn serverOut serverProc - (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread) - def - fullCaps - sessionDir - (return ()) -- No finalizer cleanup - (sendMessages clientMsgs reqSema rspSema) - takeMVar passSema - killThread sessionThread - - where - isClientMsg (FromClient _ _) = True - isClientMsg _ = False - - isServerMsg (FromServer _ _) = True - isServerMsg _ = False - -sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session () -sendMessages [] _ _ = return () -sendMessages (nextMsg:remainingMsgs) reqSema rspSema = - handleClientMessage request response notification nextMsg - where - -- TODO: May need to prevent premature exit notification being sent - notification msg@(NotificationMessage _ Exit _) = do - liftIO $ putStrLn "Will send exit notification soon" - liftIO $ threadDelay 10000000 - sendMessage msg - - liftIO $ error "Done" - - notification msg@(NotificationMessage _ m _) = do - sendMessage msg - - liftIO $ putStrLn $ "Sent a notification " ++ show m - - sendMessages remainingMsgs reqSema rspSema - - request msg@(RequestMessage _ id m _) = do - sendRequestMessage msg - liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response" - - rsp <- liftIO $ takeMVar rspSema - when (responseId id /= rsp) $ - error $ "Expected id " ++ show id ++ ", got " ++ show rsp - - sendMessages remainingMsgs reqSema rspSema - - response msg@(ResponseMessage _ id _) = do - liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server" - reqId <- liftIO $ takeMVar reqSema - if responseId reqId /= id - then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId - else do - sendResponse msg - liftIO $ putStrLn $ "Sent response to request id " ++ show id - - sendMessages remainingMsgs reqSema rspSema - -sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session () -sendRequestMessage req = do - -- Update the request map - reqMap <- requestMap <$> ask - liftIO $ modifyMVar_ reqMap $ - \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method) - - sendMessage req - - -isNotification :: FromServerMessage -> Bool -isNotification (NotPublishDiagnostics _) = True -isNotification (NotLogMessage _) = True -isNotification (NotShowMessage _) = True -isNotification (NotCancelRequestFromServer _) = True -isNotification _ = False - -listenServer :: [FromServerMessage] - -> RequestMap - -> MVar LspId - -> MVar LspIdRsp - -> MVar () - -> ThreadId - -> Handle - -> SessionContext - -> IO () -listenServer [] _ _ _ passSema _ _ _ = putMVar passSema () -listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx = do - - msgBytes <- getNextMessage serverOut - let msg = decodeFromServerMsg reqMap msgBytes - - handleServerMessage request response notification msg - - if shouldSkip msg - then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx - else if inRightOrder msg expectedMsgs - then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx - else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs - ++ [head $ dropWhile isNotification expectedMsgs] - exc = ReplayOutOfOrder msg remainingMsgs - in liftIO $ throwTo mainThreadId exc - - where - response :: ResponseMessage a -> IO () - response res = do - putStrLn $ "Got response for id " ++ show (res ^. id) - - putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request - - request :: RequestMessage ServerMethod a b -> IO () - request req = do - putStrLn - $ "Got request for id " - ++ show (req ^. id) - ++ " " - ++ show (req ^. method) - - putMVar reqSema (req ^. id) -- unblock the handler waiting for a response - - notification :: NotificationMessage ServerMethod a -> IO () - notification n = putStrLn $ "Got notification " ++ show (n ^. method) - - - --- TODO: QuickCheck tests? --- | Checks wether or not the message appears in the right order --- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @ --- given N2, notification order doesn't matter. --- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @ --- given REQ1 --- @ N1 N3 N4 N5 REQ2 RES1 @ --- given RES1 --- @ N1 N3 N4 N5 XXXX RES1 @ False! --- Order of requests and responses matter -inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool - -inRightOrder _ [] = error "Why is this empty" - -inRightOrder received (expected : msgs) - | received == expected = True - | isNotification expected = inRightOrder received msgs - | otherwise = False - --- | Ignore logging notifications since they vary from session to session -shouldSkip :: FromServerMessage -> Bool -shouldSkip (NotLogMessage _) = True -shouldSkip (NotShowMessage _) = True -shouldSkip (ReqShowMessage _) = True -shouldSkip _ = False - --- | Swaps out any commands uniqued with process IDs to match the specified process ID -swapCommands :: Int -> [Event] -> [Event] -swapCommands _ [] = [] - -swapCommands pid (FromClient t (ReqExecuteCommand req):xs) = FromClient t (ReqExecuteCommand swapped):swapCommands pid xs - where swapped = params . command .~ newCmd $ req - newCmd = swapPid pid (req ^. params . command) - -swapCommands pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapCommands pid xs - where swapped = case newCommands of - Just cmds -> result . _Right . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp - Nothing -> rsp - oldCommands = rsp ^? result . _Right . LSP.capabilities . executeCommandProvider . _Just . commands - newCommands = fmap (fmap (swapPid pid)) oldCommands - -swapCommands pid (x:xs) = x:swapCommands pid xs - -hasPid :: T.Text -> Bool -hasPid = (>= 2) . T.length . T.filter (':' ==) -swapPid :: Int -> T.Text -> T.Text -swapPid pid t - | hasPid t = T.append (T.pack $ show pid) $ T.dropWhile (/= ':') t - | otherwise = t diff --git a/src/Language/Haskell/LSP/Test/Server.hs b/src/Language/Haskell/LSP/Test/Server.hs deleted file mode 100644 --- a/src/Language/Haskell/LSP/Test/Server.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Language.Haskell.LSP.Test.Server (withServer) where - -import Control.Concurrent.Async -import Control.Monad -import Language.Haskell.LSP.Test.Compat -import System.IO -import System.Process hiding (withCreateProcess) - -withServer :: String -> Bool -> (Handle -> Handle -> ProcessHandle -> IO a) -> IO a -withServer serverExe logStdErr f = do - -- TODO Probably should just change runServer to accept - -- separate command and arguments - let cmd:args = words serverExe - createProc = (proc cmd args) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } - withCreateProcess createProc $ \(Just serverIn) (Just serverOut) (Just serverErr) serverProc -> do - -- Need to continuously consume to stderr else it gets blocked - -- Can't pass NoStream either to std_err - hSetBuffering serverErr NoBuffering - hSetBinaryMode serverErr True - let errSinkThread = forever $ hGetLine serverErr >>= when logStdErr . putStrLn - withAsync errSinkThread $ \_ -> do - f serverIn serverOut serverProc diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs deleted file mode 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ /dev/null @@ -1,441 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Language.Haskell.LSP.Test.Session - ( Session(..) - , SessionConfig(..) - , defaultConfig - , SessionMessage(..) - , SessionContext(..) - , SessionState(..) - , runSessionWithHandles - , get - , put - , modify - , modifyM - , ask - , asks - , sendMessage - , updateState - , withTimeout - , getCurTimeoutId - , bumpTimeoutId - , logMsg - , LogMsgType(..) - ) - -where - -import Control.Applicative -import Control.Concurrent hiding (yield) -import Control.Exception -import Control.Lens hiding (List) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Except -#if __GLASGOW_HASKELL__ == 806 -import Control.Monad.Fail -#endif -import Control.Monad.Trans.Reader (ReaderT, runReaderT) -import qualified Control.Monad.Trans.Reader as Reader (ask) -import Control.Monad.Trans.State (StateT, runStateT) -import qualified Control.Monad.Trans.State as State -import qualified Data.ByteString.Lazy.Char8 as B -import Data.Aeson -import Data.Aeson.Encode.Pretty -import Data.Conduit as Conduit -import Data.Conduit.Parser as Parser -import Data.Default -import Data.Foldable -import Data.List -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Data.HashMap.Strict as HashMap -import Data.Maybe -import Data.Function -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types.Capabilities -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens -import qualified Language.Haskell.LSP.Types.Lens as LSP -import Language.Haskell.LSP.VFS -import Language.Haskell.LSP.Test.Compat -import Language.Haskell.LSP.Test.Decoding -import Language.Haskell.LSP.Test.Exceptions -import System.Console.ANSI -import System.Directory -import System.IO -import System.Process (ProcessHandle()) -#ifndef mingw32_HOST_OS -import System.Process (waitForProcess) -#endif -import System.Timeout - --- | A session representing one instance of launching and connecting to a server. --- --- You can send and receive messages to the server within 'Session' via --- 'Language.Haskell.LSP.Test.message', --- 'Language.Haskell.LSP.Test.sendRequest' and --- 'Language.Haskell.LSP.Test.sendNotification'. - -newtype Session a = Session (ConduitParser FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) a) - deriving (Functor, Applicative, Monad, MonadIO, Alternative) - -#if __GLASGOW_HASKELL__ >= 806 -instance MonadFail Session where - fail s = do - lastMsg <- fromJust . lastReceivedMessage <$> get - liftIO $ throw (UnexpectedMessage s lastMsg) -#endif - --- | Stuff you can configure for a 'Session'. -data SessionConfig = SessionConfig - { messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds, defaults to 60. - , logStdErr :: Bool - -- ^ Redirect the server's stderr to this stdout, defaults to False. - -- Can be overriden with @LSP_TEST_LOG_STDERR@. - , logMessages :: Bool - -- ^ Trace the messages sent and received to stdout, defaults to False. - -- Can be overriden with the environment variable @LSP_TEST_LOG_MESSAGES@. - , logColor :: Bool -- ^ Add ANSI color to the logged messages, defaults to True. - , lspConfig :: Maybe Value -- ^ The initial LSP config as JSON value, defaults to Nothing. - , ignoreLogNotifications :: Bool - -- ^ Whether or not to ignore 'Language.Haskell.LSP.Types.ShowMessageNotification' and - -- 'Language.Haskell.LSP.Types.LogMessageNotification', defaults to False. - -- - -- @since 0.9.0.0 - } - --- | The configuration used in 'Language.Haskell.LSP.Test.runSession'. -defaultConfig :: SessionConfig -defaultConfig = SessionConfig 60 False False True Nothing False - -instance Default SessionConfig where - def = defaultConfig - -data SessionMessage = ServerMessage FromServerMessage - | TimeoutMessage Int - deriving Show - -data SessionContext = SessionContext - { - serverIn :: Handle - , rootDir :: FilePath - , messageChan :: Chan SessionMessage -- ^ Where all messages come through - -- Keep curTimeoutId in SessionContext, as its tied to messageChan - , curTimeoutId :: MVar Int -- ^ The current timeout we are waiting on - , requestMap :: MVar RequestMap - , initRsp :: MVar InitializeResponse - , config :: SessionConfig - , sessionCapabilities :: ClientCapabilities - } - -class Monad m => HasReader r m where - ask :: m r - asks :: (r -> b) -> m b - asks f = f <$> ask - -instance HasReader SessionContext Session where - ask = Session (lift $ lift Reader.ask) - -instance Monad m => HasReader r (ConduitM a b (StateT s (ReaderT r m))) where - ask = lift $ lift Reader.ask - -getCurTimeoutId :: (HasReader SessionContext m, MonadIO m) => m Int -getCurTimeoutId = asks curTimeoutId >>= liftIO . readMVar - --- Pass this the timeoutid you *were* waiting on -bumpTimeoutId :: (HasReader SessionContext m, MonadIO m) => Int -> m () -bumpTimeoutId prev = do - v <- asks curTimeoutId - -- when updating the curtimeoutid, account for the fact that something else - -- might have bumped the timeoutid in the meantime - liftIO $ modifyMVar_ v (\x -> pure (max x (prev + 1))) - -data SessionState = SessionState - { - curReqId :: LspId - , vfs :: VFS - , curDiagnostics :: Map.Map NormalizedUri [Diagnostic] - , overridingTimeout :: Bool - -- ^ The last received message from the server. - -- Used for providing exception information - , lastReceivedMessage :: Maybe FromServerMessage - , curDynCaps :: Map.Map T.Text Registration - -- ^ The capabilities that the server has dynamically registered with us so - -- far - , curProgressSessions :: Set.Set ProgressToken - } - -class Monad m => HasState s m where - get :: m s - - put :: s -> m () - - modify :: (s -> s) -> m () - modify f = get >>= put . f - - modifyM :: (HasState s m, Monad m) => (s -> m s) -> m () - modifyM f = get >>= f >>= put - -instance HasState SessionState Session where - get = Session (lift State.get) - put = Session . lift . State.put - -instance Monad m => HasState s (StateT s m) where - get = State.get - put = State.put - -instance (Monad m, (HasState s m)) => HasState s (ConduitM a b m) - where - get = lift get - put = lift . put - -instance (Monad m, (HasState s m)) => HasState s (ConduitParser a m) - where - get = lift get - put = lift . put - -runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState) -runSession context state (Session session) = runReaderT (runStateT conduit state) context - where - conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler) - - handler (Unexpected "ConduitParser.empty") = do - lastMsg <- fromJust . lastReceivedMessage <$> get - name <- getParserName - liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg) - - handler e = throw e - - chanSource = do - msg <- liftIO $ readChan (messageChan context) - unless (ignoreLogNotifications (config context) && isLogNotification msg) $ - yield msg - chanSource - - isLogNotification (ServerMessage (NotShowMessage _)) = True - isLogNotification (ServerMessage (NotLogMessage _)) = True - isLogNotification _ = False - - watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () - watchdog = Conduit.awaitForever $ \msg -> do - curId <- getCurTimeoutId - case msg of - ServerMessage sMsg -> yield sMsg - TimeoutMessage tId -> when (curId == tId) $ lastReceivedMessage <$> get >>= throw . Timeout - --- | 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 - -> Handle -- ^ Server out - -> ProcessHandle -- ^ Server process - -> (Handle -> SessionContext -> IO ()) -- ^ Server listener - -> SessionConfig - -> ClientCapabilities - -> FilePath -- ^ Root directory - -> Session () -- ^ To exit the Server properly - -> Session a - -> IO a -runSessionWithHandles serverIn serverOut serverProc serverHandler config caps rootDir exitServer session = do - absRootDir <- canonicalizePath rootDir - - hSetBuffering serverIn NoBuffering - hSetBuffering serverOut NoBuffering - -- This is required to make sure that we don’t get any - -- newline conversion or weird encoding issues. - hSetBinaryMode serverIn True - hSetBinaryMode serverOut True - - reqMap <- newMVar newRequestMap - messageChan <- newChan - timeoutIdVar <- newMVar 0 - initRsp <- newEmptyMVar - - mainThreadId <- myThreadId - - let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps - initState vfs = SessionState (IdInt 0) vfs mempty False Nothing mempty mempty - runSession' ses = initVFS $ \vfs -> runSession context (initState vfs) ses - - errorHandler = throwTo mainThreadId :: SessionException -> IO () - serverListenerLauncher = - forkIO $ catch (serverHandler serverOut context) errorHandler - server = (Just serverIn, Just serverOut, Nothing, serverProc) - msgTimeoutMs = messageTimeout config * 10^6 - serverAndListenerFinalizer tid = do - 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 - - (result, _) <- bracket serverListenerLauncher - serverAndListenerFinalizer - (const $ runSession' session) - return result - -updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () -updateStateC = awaitForever $ \msg -> do - updateState msg - yield msg - -updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) - => FromServerMessage -> m () -updateState (NotWorkDoneProgressBegin req) = - modify $ \s -> s { curProgressSessions = Set.insert (req ^. params . token) $ curProgressSessions s } -updateState (NotWorkDoneProgressEnd req) = - modify $ \s -> s { curProgressSessions = Set.delete (req ^. params . token) $ curProgressSessions s } - --- Keep track of dynamic capability registration -updateState (ReqRegisterCapability req) = do - let List newRegs = (\r -> (r ^. LSP.id, r)) <$> req ^. params . registrations - modify $ \s -> - s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) } - -updateState (ReqUnregisterCapability req) = do - let List unRegs = (^. LSP.id) <$> req ^. params . unregistrations - modify $ \s -> - let newCurDynCaps = foldr' Map.delete (curDynCaps s) unRegs - in s { curDynCaps = newCurDynCaps } - -updateState (NotPublishDiagnostics n) = do - let List diags = n ^. params . diagnostics - doc = n ^. params . uri - modify $ \s -> - let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s) - in s { curDiagnostics = newDiags } - -updateState (ReqApplyWorkspaceEdit r) = do - - -- First, prefer the versioned documentChanges field - allChangeParams <- case r ^. params . edit . documentChanges of - Just (List cs) -> do - mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs - return $ map getParams cs - -- Then fall back to the changes field - Nothing -> case r ^. params . edit . changes of - Just cs -> do - mapM_ checkIfNeedsOpened (HashMap.keys cs) - concat <$> mapM (uncurry getChangeParams) (HashMap.toList cs) - Nothing -> - error "WorkspaceEdit contains neither documentChanges nor changes!" - - modifyM $ \s -> do - newVFS <- liftIO $ changeFromServerVFS (vfs s) r - return $ s { vfs = newVFS } - - let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams - mergedParams = map mergeParams groupedParams - - -- TODO: Don't do this when replaying a session - forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange) - - -- Update VFS to new document versions - let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams - latestVersions = map ((^. textDocument) . last) sortedVersions - bumpedVersions = map (version . _Just +~ 1) latestVersions - - forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) -> - modify $ \s -> - let oldVFS = vfs s - update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver + 1) t - newVFS = updateVFS (Map.adjust update (toNormalizedUri uri)) oldVFS - in s { vfs = newVFS } - - where checkIfNeedsOpened uri = do - oldVFS <- vfs <$> get - ctx <- ask - - -- if its not open, open it - unless (toNormalizedUri uri `Map.member` vfsMap oldVFS) $ do - let fp = fromJust $ uriToFilePath uri - contents <- liftIO $ T.readFile fp - let item = TextDocumentItem (filePathToUri fp) "" 0 contents - msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item) - liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg) - - modifyM $ \s -> do - let (newVFS,_) = openVFS (vfs s) msg - return $ s { vfs = newVFS } - - getParams (TextDocumentEdit docId (List edits)) = - let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits - in DidChangeTextDocumentParams docId (List changeEvents) - - -- For a uri returns an infinite list of versions [n,n+1,n+2,...] - -- where n is the current version - textDocumentVersions uri = do - m <- vfsMap . vfs <$> get - let curVer = fromMaybe 0 $ - _lsp_version <$> m Map.!? (toNormalizedUri uri) - pure $ map (VersionedTextDocumentIdentifier uri . Just) [curVer + 1..] - - textDocumentEdits uri edits = do - vers <- textDocumentVersions uri - pure $ map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip vers edits - - getChangeParams uri (List edits) = - map <$> pure getParams <*> textDocumentEdits uri (reverse edits) - - mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams - mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params)) - in DidChangeTextDocumentParams (head params ^. textDocument) (List events) -updateState _ = return () - -sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m () -sendMessage msg = do - h <- serverIn <$> ask - logMsg LogClient msg - liftIO $ B.hPut h (addHeader $ encode msg) - --- | Execute a block f that will throw a 'Language.Haskell.LSP.Test.Exception.Timeout' exception --- after duration seconds. This will override the global timeout --- for waiting for messages to arrive defined in 'SessionConfig'. -withTimeout :: Int -> Session a -> Session a -withTimeout duration f = do - chan <- asks messageChan - timeoutId <- getCurTimeoutId - modify $ \s -> s { overridingTimeout = True } - liftIO $ forkIO $ do - threadDelay (duration * 1000000) - writeChan chan (TimeoutMessage timeoutId) - res <- f - bumpTimeoutId timeoutId - modify $ \s -> s { overridingTimeout = False } - return res - -data LogMsgType = LogServer | LogClient - deriving Eq - --- | Logs the message if the config specified it -logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m) - => LogMsgType -> a -> m () -logMsg t msg = do - shouldLog <- asks $ logMessages . config - shouldColor <- asks $ logColor . config - liftIO $ when shouldLog $ do - when shouldColor $ setSGR [SetColor Foreground Dull color] - putStrLn $ arrow ++ showPretty msg - when shouldColor $ setSGR [Reset] - - where arrow - | t == LogServer = "<-- " - | otherwise = "--> " - color - | t == LogServer = Magenta - | otherwise = Cyan - - showPretty = B.unpack . encodePretty diff --git a/src/Language/LSP/Test.hs b/src/Language/LSP/Test.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Test.hs @@ -0,0 +1,727 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ExistentialQuantification #-} + +{-| +Module : Language.LSP.Test +Description : A functional testing framework for LSP servers. +Maintainer : luke_lau@icloud.com +Stability : experimental +Portability : non-portable + +Provides the framework to start functionally testing +. +You should import "Language.LSP.Types" alongside this. +-} +module Language.LSP.Test + ( + -- * Sessions + Session + , runSession + , runSessionWithConfig + , runSessionWithHandles + -- ** Config + , SessionConfig(..) + , defaultConfig + , C.fullCaps + -- ** Exceptions + , module Language.LSP.Test.Exceptions + , withTimeout + -- * Sending + , request + , request_ + , sendRequest + , sendNotification + , sendResponse + -- * Receving + , module Language.LSP.Test.Parsing + -- * Utilities + -- | Quick helper functions for common tasks. + + -- ** Initialization + , initializeResponse + -- ** Documents + , createDoc + , openDoc + , closeDoc + , changeDoc + , documentContents + , getDocumentEdit + , getDocUri + , getVersionedDoc + -- ** Symbols + , getDocumentSymbols + -- ** Diagnostics + , waitForDiagnostics + , waitForDiagnosticsSource + , noDiagnostics + , getCurrentDiagnostics + , getIncompleteProgressSessions + -- ** Commands + , executeCommand + -- ** Code Actions + , getCodeActions + , getAllCodeActions + , executeCodeAction + -- ** Completions + , getCompletions + -- ** References + , getReferences + -- ** Definitions + , getDeclarations + , getDefinitions + , getTypeDefinitions + , getImplementations + -- ** Renaming + , rename + -- ** Hover + , getHover + -- ** Highlights + , getHighlights + -- ** Formatting + , formatDoc + , formatRange + -- ** Edits + , applyEdit + -- ** Code lenses + , getCodeLenses + -- ** Capabilities + , getRegisteredCapabilities + ) where + +import Control.Applicative.Combinators +import Control.Concurrent +import Control.Monad +import Control.Monad.IO.Class +import Control.Exception +import Control.Lens hiding ((.=), List, Empty) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Aeson +import Data.Default +import qualified Data.HashMap.Strict as HashMap +import Data.List +import Data.Maybe +import Language.LSP.Types +import Language.LSP.Types.Lens hiding + (id, capabilities, message, executeCommand, applyEdit, rename) +import qualified Language.LSP.Types.Lens as LSP +import qualified Language.LSP.Types.Capabilities as C +import Language.LSP.VFS +import Language.LSP.Test.Compat +import Language.LSP.Test.Decoding +import Language.LSP.Test.Exceptions +import Language.LSP.Test.Parsing +import Language.LSP.Test.Session +import Language.LSP.Test.Server +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. +-- +-- > runSession "hie" fullCaps "path/to/root/dir" $ do +-- > doc <- openDoc "Desktop/simple.hs" "haskell" +-- > diags <- waitForDiagnostics +-- > let pos = Position 12 5 +-- > params = TextDocumentPositionParams doc +-- > hover <- request STextdocumentHover params +runSession :: String -- ^ The command to run the server. + -> 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 +runSession = runSessionWithConfig def + +-- | Starts a new sesion with a custom configuration. +runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session. + -> String -- ^ The command to run the server. + -> 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 +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 lsp might look like: +-- +-- > (hinRead, hinWrite) <- createPipe +-- > (houtRead, houtWrite) <- createPipe +-- > +-- > forkIO $ void $ runServerWithHandles hinRead houtWrite serverDefinition +-- > 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 Nothing + (Just pid) + (Just lspTestClientInfo) + (Just $ T.pack absRootDir) + (Just $ filePathToUri absRootDir) + Nothing + caps + (Just TraceOff) + (List <$> initialWorkspaceFolders config) + runSession' serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do + -- Wrap the session around initialize and shutdown calls + initReqId <- sendRequest SInitialize initializeParams + + -- Because messages can be sent in between the request and response, + -- collect them and then... + (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId SInitialize initReqId) + + case initRspMsg ^. LSP.result of + Left error -> liftIO $ putStrLn ("Error while initializing: " ++ show error) + Right _ -> pure () + + initRspVar <- initRsp <$> ask + liftIO $ putMVar initRspVar initRspMsg + sendNotification SInitialized (Just InitializedParams) + + case lspConfig config of + Just cfg -> sendNotification SWorkspaceDidChangeConfiguration (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 + -- | Asks the server to shutdown and exit politely + exitServer :: Session () + 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 + listenServer :: Handle -> SessionContext -> IO () + listenServer serverOut context = do + msgBytes <- getNextMessage serverOut + + msg <- modifyMVar (requestMap context) $ \reqMap -> + pure $ decodeFromServerMsg reqMap msgBytes + writeChan (messageChan context) (ServerMessage msg) + + case msg of + (FromServerRsp SShutdown _) -> 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 (FromServerMess SWindowShowMessage _) = pure () + checkLegalBetweenMessage (FromServerMess SWindowLogMessage _) = pure () + checkLegalBetweenMessage (FromServerMess STelemetryEvent _) = pure () + checkLegalBetweenMessage (FromServerMess SWindowShowMessageRequest _) = 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 (virtualFileText file) + +-- | Parses an ApplyEditRequest, checks that it is for the passed document +-- and returns the new content +getDocumentEdit :: TextDocumentIdentifier -> Session T.Text +getDocumentEdit doc = do + req <- message SWorkspaceApplyEdit + + unless (checkDocumentChanges req || checkChanges req) $ + liftIO $ throw (IncorrectApplyEditRequest (show req)) + + documentContents doc + where + checkDocumentChanges req = + let changes = req ^. params . edit . documentChanges + maybeDocs = fmap (fmap documentChangeUri) changes + in case maybeDocs of + Just docs -> (doc ^. uri) `elem` docs + Nothing -> False + checkChanges req = + let mMap = req ^. params . edit . changes + in maybe False (HashMap.member (doc ^. uri)) mMap + +-- | Sends a request to the server and waits for its response. +-- Will skip any messages in between the request and the response +-- @ +-- rsp <- request STextDocumentDocumentSymbol params +-- @ +-- 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 m + +-- | The same as 'sendRequest', but discard the response. +request_ :: SClientMethod (m :: Method FromClient Request) -> MessageParams m -> Session () +request_ p = void . request p + +-- | Sends a request to the server. Unlike 'request', this doesn't wait for the response. +sendRequest + :: SClientMethod m -- ^ The request method. + -> MessageParams m -- ^ The request parameters. + -> Session (LspId m) -- ^ The id of the request that was sent. +sendRequest method params = do + idn <- curReqId <$> get + modify $ \c -> c { curReqId = idn+1 } + let id = IdInt idn + + let mess = RequestMessage "2.0" id method params + + -- Update the request map + reqMap <- requestMap <$> ask + liftIO $ modifyMVar_ reqMap $ + \r -> return $ fromJust $ updateRequestMap r id method + + ~() <- case splitClientMethod method of + IsClientReq -> sendMessage mess + IsClientEither -> sendMessage $ ReqMess mess + + return id + +-- | Sends a notification to the server. +sendNotification :: SClientMethod (m :: Method FromClient Notification) -- ^ The notification method. + -> MessageParams m -- ^ The notification parameters. + -> Session () +-- Open a virtual file if we send a did open text document notification +sendNotification STextDocumentDidOpen params = do + let n = NotificationMessage "2.0" STextDocumentDidOpen params + oldVFS <- vfs <$> get + let (newVFS,_) = openVFS oldVFS n + modify (\s -> s { vfs = newVFS }) + sendMessage n + +-- Close a virtual file if we send a close text document notification +sendNotification STextDocumentDidClose params = do + let n = NotificationMessage "2.0" STextDocumentDidClose params + oldVFS <- vfs <$> get + let (newVFS,_) = closeVFS oldVFS n + modify (\s -> s { vfs = newVFS }) + sendMessage n + +sendNotification STextDocumentDidChange params = do + let n = NotificationMessage "2.0" STextDocumentDidChange params + oldVFS <- vfs <$> get + let (newVFS,_) = changeFromClientVFS oldVFS n + modify (\s -> s { vfs = newVFS }) + sendMessage n + +sendNotification method params = + case splitClientMethod method of + IsClientNot -> sendMessage (NotificationMessage "2.0" method params) + IsClientEither -> sendMessage (NotMess $ NotificationMessage "2.0" method params) + +-- | Sends a response to the server. +sendResponse :: ToJSON (ResponseResult m) => ResponseMessage m -> Session () +sendResponse = sendMessage + +-- | Returns the initialize response that was received from the server. +-- The initialize requests and responses are not included the session, +-- so if you need to test it use this. +initializeResponse :: Session (ResponseMessage Initialize) +initializeResponse = ask >>= (liftIO . readMVar) . initRsp + +-- | /Creates/ a new text document. This is different from 'openDoc' +-- as it sends a workspace/didChangeWatchedFiles notification letting the server +-- know that a file was created within the workspace, __provided that the server +-- has registered for it__, and the file matches any patterns the server +-- registered for. +-- It /does not/ actually create a file on disk, but is useful for convincing +-- the server that one does exist. +-- +-- @since 11.0.0.0 +createDoc :: FilePath -- ^ The path to the document to open, __relative to the root directory__. + -> T.Text -- ^ The text document's language identifier, e.g. @"haskell"@. + -> T.Text -- ^ The content of the text document to create. + -> Session TextDocumentIdentifier -- ^ The identifier of the document just created. +createDoc file languageId contents = do + dynCaps <- curDynCaps <$> get + rootDir <- asks rootDir + caps <- asks sessionCapabilities + absFile <- liftIO $ canonicalizePath (rootDir file) + 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 + fileMatches (T.unpack pattern) && createHits (fromMaybe (WatchKind True True True) kind) + + fileMatches pattern = Glob.match (Glob.compile pattern) relOrAbs + -- If the pattern is absolute then match against the absolute fp + where relOrAbs + | isAbsolute pattern = absFile + | otherwise = file + + createHits (WatchKind create _ _) = create + + regHits :: Registration WorkspaceDidChangeWatchedFiles -> Bool + regHits reg = foldl' (\acc w -> acc || watchHits w) False (reg ^. registerOptions . watchers) + + clientCapsSupports = + caps ^? workspace . _Just . didChangeWatchedFiles . _Just . dynamicRegistration . _Just + == Just True + shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs + + when shouldSend $ + sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + List [ FileEvent (filePathToUri (rootDir file)) FcCreated ] + openDoc' file languageId contents + +-- | Opens a text document that /exists on disk/, and sends a +-- textDocument/didOpen notification to the server. +openDoc :: FilePath -> T.Text -> Session TextDocumentIdentifier +openDoc file languageId = do + context <- ask + let fp = rootDir context file + contents <- liftIO $ T.readFile fp + openDoc' file languageId contents + +-- | This is a variant of `openDoc` that takes the file content as an argument. +-- Use this is the file exists /outside/ of the current workspace. +openDoc' :: FilePath -> T.Text -> T.Text -> Session TextDocumentIdentifier +openDoc' file languageId contents = do + context <- ask + let fp = rootDir context file + uri = filePathToUri fp + item = TextDocumentItem uri languageId 0 contents + sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams item) + pure $ TextDocumentIdentifier uri + +-- | Closes a text document and sends a textDocument/didOpen notification to the server. +closeDoc :: TextDocumentIdentifier -> Session () +closeDoc docId = do + let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri)) + sendNotification STextDocumentDidClose params + +-- | Changes a text document and sends a textDocument/didOpen notification to the server. +changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session () +changeDoc docId changes = do + verDoc <- getVersionedDoc docId + let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes) + sendNotification STextDocumentDidChange params + +-- | Gets the Uri for the file corrected to the session directory. +getDocUri :: FilePath -> Session Uri +getDocUri file = do + context <- ask + 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 (message STextDocumentPublishDiagnostics) + let (List diags) = diagsNot ^. params . LSP.diagnostics + return diags + +-- | The same as 'waitForDiagnostics', but will only match a specific +-- 'Language.LSP.Types._source'. +waitForDiagnosticsSource :: String -> Session [Diagnostic] +waitForDiagnosticsSource src = do + diags <- waitForDiagnostics + let res = filter matches diags + if null res + then waitForDiagnosticsSource src + else return res + where + matches :: Diagnostic -> Bool + matches d = d ^. source == Just (T.pack src) + +-- | Expects a 'PublishDiagnosticsNotification' and throws an +-- 'UnexpectedDiagnostics' exception if there are any diagnostics +-- returned. +noDiagnostics :: Session () +noDiagnostics = do + diagsNot <- message STextDocumentPublishDiagnostics + when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics + +-- | Returns the symbols in a document. +getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation]) +getDocumentSymbols doc = do + ResponseMessage _ rspLid res <- request STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) + case res of + Right (InL (List xs)) -> return (Left xs) + Right (InR (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 [Command |? CodeAction] +getCodeActions doc range = do + ctx <- getCodeActionContext doc + rsp <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc range ctx) + + case rsp ^. result of + Right (List xs) -> return xs + Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) error) + +-- | Returns all the code actions in a document by +-- querying the code actions at each of the current +-- diagnostics' positions. +getAllCodeActions :: TextDocumentIdentifier -> Session [Command |? CodeAction] +getAllCodeActions doc = do + ctx <- getCodeActionContext doc + + foldM (go ctx) [] =<< getCurrentDiagnostics doc + + where + go :: CodeActionContext -> [Command |? CodeAction] -> Diagnostic -> Session [Command |? CodeAction] + go ctx acc diag = do + ResponseMessage _ rspLid res <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. range) ctx) + + case res of + Left e -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) e) + Right (List cmdOrCAs) -> pure (acc ++ cmdOrCAs) + +getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext +getCodeActionContext doc = do + curDiags <- getCurrentDiagnostics doc + return $ CodeActionContext (List curDiags) Nothing + +-- | Returns the current diagnostics that have been sent to the client. +-- Note that this does not wait for more to come in. +getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic] +getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. uri) . curDiagnostics <$> get + +-- | Returns the tokens of all progress sessions that have started but not yet ended. +getIncompleteProgressSessions :: Session (Set.Set ProgressToken) +getIncompleteProgressSessions = curProgressSessions <$> get + +-- | Executes a command. +executeCommand :: Command -> Session () +executeCommand cmd = do + let args = decode $ encode $ fromJust $ cmd ^. arguments + execParams = ExecuteCommandParams Nothing (cmd ^. command) args + void $ sendRequest SWorkspaceExecuteCommand 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 + maybe (return ()) executeCommand $ action ^. command + + 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 Nothing e) + in updateState (FromServerMess SWorkspaceApplyEdit req) + +-- | Adds the current version to the document, as tracked by the session. +getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier +getVersionedDoc (TextDocumentIdentifier uri) = do + fs <- vfsMap . vfs <$> get + let ver = + case fs Map.!? toNormalizedUri uri of + Just vf -> Just (virtualFileVersion vf) + _ -> 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 sessionCapabilities + + let supportsDocChanges = fromMaybe False $ do + let mWorkspace = caps ^. LSP.workspace + C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace + C.WorkspaceEditClientCapabilities mDocChanges _ _ <- mEdit + mDocChanges + + let wEdit = if supportsDocChanges + then + let docEdit = TextDocumentEdit verDoc (List [edit]) + in WorkspaceEdit Nothing (Just (List [InL docEdit])) + else + let changes = HashMap.singleton (doc ^. uri) (List [edit]) + in WorkspaceEdit (Just changes) Nothing + + let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) + updateState (FromServerMess SWorkspaceApplyEdit 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 <- request STextDocumentCompletion (CompletionParams doc pos Nothing Nothing Nothing) + + case getResponseResult rsp of + InL (List items) -> return items + InR (CompletionList _ (List items)) -> return items + +-- | Returns the references for the position in the document. +getReferences :: TextDocumentIdentifier -- ^ The document to lookup in. + -> Position -- ^ The position to lookup. + -> Bool -- ^ Whether to include declarations as references. + -> Session (List Location) -- ^ The locations of the references. +getReferences doc pos inclDecl = + let ctx = ReferenceContext inclDecl + 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] |? [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] |? [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 :: (ResponseResult 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 + InL loc -> pure (InL [loc]) + InR (InL (List locs)) -> pure (InL locs) + InR (InR (List locLinks)) -> pure (InR locLinks) + +-- | Renames the term at the specified position. +rename :: TextDocumentIdentifier -> Position -> String -> Session () +rename doc pos newName = do + let params = RenameParams doc pos Nothing (T.pack newName) + rsp <- request STextDocumentRename params + let wEdit = getResponseResult rsp + 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 doc pos = + 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 = DocumentHighlightParams doc pos Nothing Nothing + in getResponseResult <$> request STextDocumentDocumentHighlight params + +-- | Checks the response for errors and throws an exception if needed. +-- Returns the result if successful. +getResponseResult :: ResponseMessage m -> ResponseResult m +getResponseResult rsp = + case rsp ^. result of + Right x -> x + Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) err + +-- | Applies formatting to the specified document. +formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session () +formatDoc doc opts = do + 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 Nothing doc range opts + edits <- getResponseResult <$> request STextDocumentRangeFormatting params + applyTextEdits doc edits + +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 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 Nothing Nothing tId) + case getResponseResult rsp of + List res -> pure res + +-- | Returns a list of capabilities that the server has requested to /dynamically/ +-- register during the 'Session'. +-- +-- @since 0.11.0.0 +getRegisteredCapabilities :: Session [SomeRegistration] +getRegisteredCapabilities = Map.elems . curDynCaps <$> get diff --git a/src/Language/LSP/Test/Compat.hs b/src/Language/LSP/Test/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Test/Compat.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +-- For some reason ghc warns about not using +-- Control.Monad.IO.Class but it's needed for +-- MonadIO +{-# OPTIONS_GHC -Wunused-imports #-} +module Language.LSP.Test.Compat where + +import Data.Maybe +import System.IO +import Language.LSP.Types + +#if MIN_VERSION_process(1,6,3) +-- We have to hide cleanupProcess for process-1.6.3.0 +-- cause it is in the public api for 1.6.3.0 versions +-- shipped with ghc >= 8.6 and < 8.6.4 +import System.Process hiding (getPid, cleanupProcess, withCreateProcess) +# if MIN_VERSION_process(1,6,4) +import qualified System.Process (getPid, cleanupProcess, withCreateProcess) +# else +import Foreign.C.Error +import GHC.IO.Exception ( IOErrorType(..), IOException(..) ) + +import qualified System.Process (getPid) +import qualified Control.Exception as C +# endif +#else +import Control.Concurrent.MVar +import Foreign.C.Error +import GHC.IO.Exception ( IOErrorType(..), IOException(..) ) +import System.Process hiding (withCreateProcess) +import System.Process.Internals + +import qualified Control.Exception as C +#endif + +#ifdef mingw32_HOST_OS +import qualified System.Win32.Process +#else +import qualified System.Posix.Process +#endif + + +getCurrentProcessID :: IO Int +#ifdef mingw32_HOST_OS +getCurrentProcessID = fromIntegral <$> System.Win32.Process.getCurrentProcessId +#else +getCurrentProcessID = fromIntegral <$> System.Posix.Process.getProcessID +#endif + +getProcessID :: ProcessHandle -> IO Int +getProcessID p = fromIntegral . fromJust <$> getProcessID' p + where +#if MIN_VERSION_process(1,6,3) + getProcessID' = System.Process.getPid +#else +#if MIN_VERSION_process(1,6,0) + getProcessID' (ProcessHandle mh _ _) = do +#else + getProcessID' (ProcessHandle mh _) = do +#endif + p_ <- readMVar mh + case p_ of +#ifdef mingw32_HOST_OS + OpenHandle h -> do + pid <- System.Win32.Process.getProcessId h + return $ Just pid +#else + OpenHandle pid -> return $ Just pid +#endif + _ -> return Nothing +#endif + +cleanupProcess + :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () + +withCreateProcess + :: CreateProcess + -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) + -> IO a + +#if MIN_VERSION_process(1,6,4) + +cleanupProcess = System.Process.cleanupProcess + +withCreateProcess = System.Process.withCreateProcess + +#else + +cleanupProcess (mb_stdin, mb_stdout, mb_stderr, ph) = do + -- We ignore the spurious "permission denied" error in windows: + -- see https://github.com/haskell/process/issues/110 + ignorePermDenied $ terminateProcess ph + -- Note, it's important that other threads that might be reading/writing + -- these handles also get killed off, since otherwise they might be holding + -- the handle lock and prevent us from closing, leading to deadlock. + maybe (return ()) (ignoreSigPipe . hClose) mb_stdin + maybe (return ()) hClose mb_stdout + maybe (return ()) hClose mb_stderr + + return () + where ignoreSigPipe = ignoreIOError ResourceVanished ePIPE + ignorePermDenied = ignoreIOError PermissionDenied eACCES + +ignoreIOError :: IOErrorType -> Errno -> IO () -> IO () +ignoreIOError ioErrorType errno = + C.handle $ \e -> case e of + IOError { ioe_type = iot + , ioe_errno = Just ioe } + | iot == ioErrorType && Errno ioe == errno -> return () + _ -> C.throwIO e + +withCreateProcess c action = + C.bracket (createProcess c) cleanupProcess + (\(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/LSP/Test/Decoding.hs b/src/Language/LSP/Test/Decoding.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Test/Decoding.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeInType #-} +module Language.LSP.Test.Decoding where + +import Prelude hiding ( id ) +import Data.Aeson +import Data.Aeson.Types +import Data.Foldable +import Data.Functor.Product +import Data.Functor.Const +import Control.Exception +import Control.Lens +import qualified Data.ByteString.Lazy.Char8 as B +import Data.Maybe +import System.IO +import System.IO.Error +import Language.LSP.Types +import Language.LSP.Types.Lens +import Language.LSP.Test.Exceptions + +import Data.IxMap +import Data.Kind + +getAllMessages :: Handle -> IO [B.ByteString] +getAllMessages h = do + done <- hIsEOF h + if done + then return [] + else do + msg <- getNextMessage h + + (msg :) <$> getAllMessages h + +-- | Fetches the next message bytes based on +-- the Content-Length header +getNextMessage :: Handle -> IO B.ByteString +getNextMessage h = do + headers <- getHeaders h + case read . init <$> lookup "Content-Length" headers of + Nothing -> throw NoContentLengthHeader + Just size -> B.hGet h size + +addHeader :: B.ByteString -> B.ByteString +addHeader content = B.concat + [ "Content-Length: " + , B.pack $ show $ B.length content + , "\r\n" + , "\r\n" + , content + ] + +getHeaders :: Handle -> IO [(String, String)] +getHeaders h = do + l <- catch (hGetLine h) eofHandler + let (name, val) = span (/= ':') l + if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h + where eofHandler e + | isEOFError e = throw UnexpectedServerTermination + | otherwise = throw e + +type RequestMap = IxMap LspId (SMethod :: Method FromClient Request -> Type ) + +newRequestMap :: RequestMap +newRequestMap = emptyIxMap + +updateRequestMap :: RequestMap -> LspId m -> SClientMethod m -> Maybe RequestMap +updateRequestMap reqMap id method = insertIxMap id method reqMap + +getRequestMap :: [FromClientMessage] -> RequestMap +getRequestMap = foldl' helper emptyIxMap + where + helper :: RequestMap -> FromClientMessage -> RequestMap + helper acc msg = case msg of + FromClientMess m mess -> case splitClientMethod m of + IsClientNot -> acc + IsClientReq -> fromJust $ updateRequestMap acc (mess ^. id) m + IsClientEither -> case mess of + NotMess _ -> acc + ReqMess msg -> fromJust $ updateRequestMap acc (msg ^. id) m + _ -> acc + +decodeFromServerMsg :: RequestMap -> B.ByteString -> (RequestMap, FromServerMessage) +decodeFromServerMsg reqMap bytes = unP $ fromJust $ parseMaybe p obj + where obj = fromJust $ decode bytes :: Value + p = parseServerMessage $ \lid -> + let (mm, newMap) = pickFromIxMap lid reqMap + in case mm of + Nothing -> Nothing + Just m -> Just $ (m, Pair m (Const newMap)) + unP (FromServerMess m msg) = (reqMap, FromServerMess m msg) + unP (FromServerRsp (Pair m (Const newMap)) msg) = (newMap, FromServerRsp m msg) + {- + WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet" + WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet" + CustomServerMethod _ + | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes + | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes + | otherwise -> NotCustomServer $ fromJust $ decode bytes + + Error e -> error e + -} diff --git a/src/Language/LSP/Test/Exceptions.hs b/src/Language/LSP/Test/Exceptions.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Test/Exceptions.hs @@ -0,0 +1,59 @@ +module Language.LSP.Test.Exceptions where + +import Control.Exception +import Language.LSP.Types +import Data.Aeson +import Data.Aeson.Encode.Pretty +import Data.Algorithm.Diff +import Data.Algorithm.DiffOutput +import Data.List +import qualified Data.ByteString.Lazy.Char8 as B + +-- | An exception that can be thrown during a 'Haskell.LSP.Test.Session.Session' +data SessionException = Timeout (Maybe FromServerMessage) + | NoContentLengthHeader + | UnexpectedMessage String FromServerMessage + | ReplayOutOfOrder FromServerMessage [FromServerMessage] + | UnexpectedDiagnostics + | IncorrectApplyEditRequest String + | UnexpectedResponseError SomeLspId ResponseError + | UnexpectedServerTermination + | IllegalInitSequenceMessage FromServerMessage + deriving Eq + +instance Exception SessionException + +instance Show SessionException where + show (Timeout lastMsg) = + "Timed out waiting to receive a message from the server." ++ + case lastMsg of + Just msg -> "\nLast message received:\n" ++ B.unpack (encodePretty msg) + Nothing -> mempty + show NoContentLengthHeader = "Couldn't read Content-Length header from the server." + show (UnexpectedMessage expected lastMsg) = + "Received an unexpected message from the server:\n" ++ + "Was parsing: " ++ expected ++ "\n" ++ + "But the last message received was:\n" ++ B.unpack (encodePretty lastMsg) + show (ReplayOutOfOrder received expected) = + let expected' = nub expected + getJsonDiff = lines . B.unpack . encodePretty + showExp exp = B.unpack (encodePretty exp) ++ "\nDiff:\n" ++ + ppDiff (getGroupedDiff (getJsonDiff received) (getJsonDiff exp)) + in "Replay is out of order:\n" ++ + -- Print json so its a bit easier to update the session logs + "Received from server:\n" ++ B.unpack (encodePretty received) ++ "\n" ++ + "Raw from server:\n" ++ B.unpack (encode received) ++ "\n" ++ + "Expected one of:\n" ++ unlines (map showExp expected') + show UnexpectedDiagnostics = "Unexpectedly received diagnostics from the server." + show (IncorrectApplyEditRequest msgStr) = "ApplyEditRequest didn't contain document, instead received:\n" + ++ msgStr + show (UnexpectedResponseError lid e) = "Received an exepected error in a response for id " ++ show lid ++ ":\n" + ++ show e + show UnexpectedServerTermination = "Language server unexpectedly terminated" + show (IllegalInitSequenceMessage msg) = + "Received an illegal message between the initialize request and response:\n" + ++ B.unpack (encodePretty msg) + +-- | A predicate that matches on any 'SessionException' +anySessionException :: SessionException -> Bool +anySessionException = const True diff --git a/src/Language/LSP/Test/Files.hs b/src/Language/LSP/Test/Files.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Test/Files.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +module Language.LSP.Test.Files + ( swapFiles + , rootDir + ) +where + +import Language.LSP.Types +import Language.LSP.Types.Lens hiding (id) +import Control.Lens +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import Data.Maybe +import System.Directory +import System.FilePath +import Data.Time.Clock + +data Event + = ClientEv UTCTime FromClientMessage + | ServerEv UTCTime FromServerMessage + +swapFiles :: FilePath -> [Event] -> IO [Event] +swapFiles relCurBaseDir msgs = do + let capturedBaseDir = rootDir msgs + + curBaseDir <- ( relCurBaseDir) <$> getCurrentDirectory + let transform uri = + let fp = fromMaybe (error "Couldn't transform uri") (uriToFilePath uri) + newFp = curBaseDir makeRelative capturedBaseDir fp + in filePathToUri newFp + newMsgs = map (mapUris transform) msgs + + return newMsgs + +rootDir :: [Event] -> FilePath +rootDir (ClientEv _ (FromClientMess SInitialize req):_) = + fromMaybe (error "Couldn't find root dir") $ do + rootUri <- req ^. params .rootUri + uriToFilePath rootUri +rootDir _ = error "Couldn't find initialize request in session" + +mapUris :: (Uri -> Uri) -> Event -> Event +mapUris f event = + case event of + ClientEv t msg -> ClientEv t (fromClientMsg msg) + ServerEv t msg -> ServerEv t (fromServerMsg msg) + + where + --TODO: Handle all other URIs that might need swapped + fromClientMsg (FromClientMess m@SInitialize r) = FromClientMess m $ params .~ transformInit (r ^. params) $ r + fromClientMsg (FromClientMess m@STextDocumentDidOpen n) = FromClientMess m $ swapUri (params . textDocument) n + fromClientMsg (FromClientMess m@STextDocumentDidChange n) = FromClientMess m $ swapUri (params . textDocument) n + fromClientMsg (FromClientMess m@STextDocumentWillSave n) = FromClientMess m $ swapUri (params . textDocument) n + fromClientMsg (FromClientMess m@STextDocumentDidSave n) = FromClientMess m $ swapUri (params . textDocument) n + fromClientMsg (FromClientMess m@STextDocumentDidClose n) = FromClientMess m $ swapUri (params . textDocument) n + fromClientMsg (FromClientMess m@STextDocumentDocumentSymbol n) = FromClientMess m $ swapUri (params . textDocument) n + fromClientMsg (FromClientMess m@STextDocumentRename n) = FromClientMess m $ swapUri (params . textDocument) n + fromClientMsg x = x + + fromServerMsg :: FromServerMessage -> FromServerMessage + fromServerMsg (FromServerMess m@SWorkspaceApplyEdit r) = FromServerMess m $ params . edit .~ swapWorkspaceEdit (r ^. params . edit) $ r + fromServerMsg (FromServerMess m@STextDocumentPublishDiagnostics n) = FromServerMess m $ swapUri params n + fromServerMsg (FromServerRsp m@STextDocumentDocumentSymbol r) = + let swapUri' :: (List DocumentSymbol |? List SymbolInformation) -> List DocumentSymbol |? List SymbolInformation + swapUri' (InR si) = InR (swapUri location <$> si) + swapUri' (InL dss) = InL dss -- no file locations here + in FromServerRsp m $ r & result %~ (fmap swapUri') + fromServerMsg (FromServerRsp m@STextDocumentRename r) = FromServerRsp m $ r & result %~ (fmap swapWorkspaceEdit) + fromServerMsg x = x + + swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit + swapWorkspaceEdit e = + let swapDocumentChangeUri :: DocumentChange -> DocumentChange + swapDocumentChangeUri (InL textDocEdit) = InL $ swapUri textDocument textDocEdit + swapDocumentChangeUri (InR (InL createFile)) = InR $ InL $ swapUri id createFile + -- for RenameFile, we swap `newUri` + swapDocumentChangeUri (InR (InR (InL renameFile))) = InR $ InR $ InL $ newUri .~ f (renameFile ^. newUri) $ renameFile + swapDocumentChangeUri (InR (InR (InR deleteFile))) = InR $ InR $ InR $ swapUri id deleteFile + + newDocChanges = fmap (fmap swapDocumentChangeUri) $ e ^. documentChanges + newChanges = fmap (swapKeys f) $ e ^. changes + in WorkspaceEdit newChanges newDocChanges + + swapKeys :: (Uri -> Uri) -> HM.HashMap Uri b -> HM.HashMap Uri b + swapKeys f = HM.foldlWithKey' (\acc k v -> HM.insert (f k) v acc) HM.empty + + swapUri :: HasUri b Uri => Lens' a b -> a -> a + swapUri lens x = + let newUri = f (x ^. lens . uri) + in (lens . uri) .~ newUri $ x + + -- | Transforms rootUri/rootPath. + transformInit :: InitializeParams -> InitializeParams + transformInit x = + let newRootUri = fmap f (x ^. rootUri) + newRootPath = do + fp <- T.unpack <$> x ^. rootPath + let uri = filePathToUri fp + T.pack <$> uriToFilePath (f uri) + in (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x diff --git a/src/Language/LSP/Test/Parsing.hs b/src/Language/LSP/Test/Parsing.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Test/Parsing.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Language.LSP.Test.Parsing + ( -- $receiving + satisfy + , satisfyMaybe + , message + , response + , responseForId + , customRequest + , customNotification + , anyRequest + , anyResponse + , anyNotification + , anyMessage + , loggingNotification + , publishDiagnosticsNotification + ) where + +import Control.Applicative +import Control.Concurrent +import Control.Monad.IO.Class +import Control.Monad +import Data.Conduit.Parser hiding (named) +import qualified Data.Conduit.Parser (named) +import qualified Data.Text as T +import Data.Typeable +import Language.LSP.Types +import Language.LSP.Test.Session + +-- $receiving +-- To receive a message, specify the method of the message to expect: +-- +-- @ +-- msg1 <- message SWorkspaceApplyEdit +-- msg2 <- message STextDocumentHover +-- @ +-- +-- 'Language.LSP.Test.Session' is actually just a parser +-- that operates on messages under the hood. This means that you +-- can create and combine parsers to match speicifc sequences of +-- messages that you expect. +-- +-- For example, if you wanted to match either a definition or +-- references request: +-- +-- > defOrImpl = message STextDocumentDefinition +-- > <|> message STextDocumentReferences +-- +-- If you wanted to match any number of telemetry +-- notifications immediately followed by a response: +-- +-- @ +-- logThenDiags = +-- skipManyTill (message STelemetryEvent) +-- anyResponse +-- @ + +-- | Consumes and returns the next message, if it satisfies the specified predicate. +-- +-- @since 0.5.2.0 +satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage +satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing) + +-- | Consumes and returns the result of the specified predicate if it returns `Just`. +-- +-- @since 0.6.1.0 +satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a +satisfyMaybe pred = satisfyMaybeM (pure . pred) + +satisfyMaybeM :: (FromServerMessage -> Session (Maybe a)) -> Session a +satisfyMaybeM pred = do + + skipTimeout <- overridingTimeout <$> get + timeoutId <- getCurTimeoutId + unless skipTimeout $ do + chan <- asks messageChan + timeout <- asks (messageTimeout . config) + void $ liftIO $ forkIO $ do + threadDelay (timeout * 1000000) + writeChan chan (TimeoutMessage timeoutId) + + x <- Session await + + unless skipTimeout (bumpTimeoutId timeoutId) + + modify $ \s -> s { lastReceivedMessage = Just x } + + res <- pred x + + case res of + Just a -> do + logMsg LogServer x + return a + Nothing -> empty + +named :: T.Text -> Session a -> Session a +named s (Session x) = Session (Data.Conduit.Parser.named s x) + + +-- | Matches a request or a notification coming from the server. +message :: SServerMethod m -> Session (ServerMessage m) +message m1 = named (T.pack $ "Request for: " <> show m1) $ satisfyMaybe $ \case + FromServerMess m2 msg -> do + HRefl <- mEqServer m1 m2 + pure msg + _ -> Nothing + +customRequest :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Request)) +customRequest m = named m $ satisfyMaybe $ \case + FromServerMess m1 msg -> case splitServerMethod m1 of + IsServerEither -> case msg of + ReqMess _ | m1 == SCustomMethod m -> Just msg + _ -> Nothing + _ -> Nothing + _ -> Nothing + +customNotification :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Notification)) +customNotification m = named m $ satisfyMaybe $ \case + FromServerMess m1 msg -> case splitServerMethod m1 of + IsServerEither -> case msg of + NotMess _ | m1 == SCustomMethod m -> Just msg + _ -> Nothing + _ -> Nothing + _ -> Nothing + +-- | Matches if the message is a notification. +anyNotification :: Session FromServerMessage +anyNotification = named "Any notification" $ satisfy $ \case + FromServerMess m msg -> case splitServerMethod m of + IsServerNot -> True + IsServerEither -> case msg of + NotMess _ -> True + _ -> False + _ -> False + FromServerRsp _ _ -> False + +-- | Matches if the message is a request. +anyRequest :: Session FromServerMessage +anyRequest = named "Any request" $ satisfy $ \case + FromServerMess m _ -> case splitServerMethod m of + IsServerReq -> True + _ -> False + FromServerRsp _ _ -> False + +-- | Matches if the message is a response. +anyResponse :: Session FromServerMessage +anyResponse = named "Any response" $ satisfy $ \case + FromServerMess _ _ -> False + FromServerRsp _ _ -> True + +-- | Matches a response coming from the server. +response :: SMethod (m :: Method FromClient Request) -> Session (ResponseMessage m) +response m1 = named (T.pack $ "Response for: " <> show m1) $ satisfyMaybe $ \case + FromServerRsp m2 msg -> do + HRefl <- mEqClient m1 m2 + pure msg + _ -> Nothing + +-- | Like 'response', but matches a response for a specific id. +responseForId :: SMethod (m :: Method FromClient Request) -> LspId m -> Session (ResponseMessage m) +responseForId m lid = named (T.pack $ "Response for id: " ++ show lid) $ do + satisfyMaybe $ \msg -> do + case msg of + FromServerMess _ _ -> Nothing + FromServerRsp m' rspMsg@(ResponseMessage _ lid' _) -> + case mEqClient m m' of + Just HRefl -> do + guard (lid' == Just lid) + pure rspMsg + Nothing + | SCustomMethod tm <- m + , SCustomMethod tm' <- m' + , tm == tm' + , lid' == Just lid -> pure rspMsg + _ -> empty + +-- | Matches any type of message. +anyMessage :: Session FromServerMessage +anyMessage = satisfy (const True) + +-- | Matches if the message is a log message notification or a show message notification/request. +loggingNotification :: Session FromServerMessage +loggingNotification = named "Logging notification" $ satisfy shouldSkip + where + shouldSkip (FromServerMess SWindowLogMessage _) = True + shouldSkip (FromServerMess SWindowShowMessage _) = True + shouldSkip (FromServerMess SWindowShowMessageRequest _) = True + shouldSkip _ = False + +-- | Matches a 'Language.LSP.Types.TextDocumentPublishDiagnostics' +-- (textDocument/publishDiagnostics) notification. +publishDiagnosticsNotification :: Session (Message TextDocumentPublishDiagnostics) +publishDiagnosticsNotification = named "Publish diagnostics notification" $ + satisfyMaybe $ \msg -> case msg of + FromServerMess STextDocumentPublishDiagnostics diags -> Just diags + _ -> Nothing diff --git a/src/Language/LSP/Test/Server.hs b/src/Language/LSP/Test/Server.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Test/Server.hs @@ -0,0 +1,22 @@ +module Language.LSP.Test.Server (withServer) where + +import Control.Concurrent.Async +import Control.Monad +import Language.LSP.Test.Compat +import System.IO +import System.Process hiding (withCreateProcess) + +withServer :: String -> Bool -> (Handle -> Handle -> ProcessHandle -> IO a) -> IO a +withServer serverExe logStdErr f = do + -- TODO Probably should just change runServer to accept + -- separate command and arguments + let cmd:args = words serverExe + createProc = (proc cmd args) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } + withCreateProcess createProc $ \(Just serverIn) (Just serverOut) (Just serverErr) serverProc -> do + -- Need to continuously consume to stderr else it gets blocked + -- Can't pass NoStream either to std_err + hSetBuffering serverErr NoBuffering + hSetBinaryMode serverErr True + let errSinkThread = forever $ hGetLine serverErr >>= when logStdErr . putStrLn + withAsync errSinkThread $ \_ -> do + f serverIn serverOut serverProc diff --git a/src/Language/LSP/Test/Session.hs b/src/Language/LSP/Test/Session.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Test/Session.hs @@ -0,0 +1,473 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeInType #-} + +module Language.LSP.Test.Session + ( Session(..) + , SessionConfig(..) + , defaultConfig + , SessionMessage(..) + , SessionContext(..) + , SessionState(..) + , runSession' + , get + , put + , modify + , modifyM + , ask + , asks + , sendMessage + , updateState + , withTimeout + , getCurTimeoutId + , bumpTimeoutId + , logMsg + , LogMsgType(..) + , documentChangeUri + ) + +where + +import Control.Applicative +import Control.Concurrent hiding (yield) +import Control.Exception +import Control.Lens hiding (List) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Except +#if __GLASGOW_HASKELL__ == 806 +import Control.Monad.Fail +#endif +import Control.Monad.Trans.Reader (ReaderT, runReaderT) +import qualified Control.Monad.Trans.Reader as Reader (ask) +import Control.Monad.Trans.State (StateT, runStateT) +import qualified Control.Monad.Trans.State as State +import qualified Data.ByteString.Lazy.Char8 as B +import Data.Aeson +import Data.Aeson.Encode.Pretty +import Data.Conduit as Conduit +import Data.Conduit.Parser as Parser +import Data.Default +import Data.Foldable +import Data.List +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.HashMap.Strict as HashMap +import Data.Maybe +import Data.Function +import Language.LSP.Types.Capabilities +import Language.LSP.Types +import Language.LSP.Types.Lens +import qualified Language.LSP.Types.Lens as LSP +import Language.LSP.VFS +import Language.LSP.Test.Compat +import Language.LSP.Test.Decoding +import Language.LSP.Test.Exceptions +import System.Console.ANSI +import System.Directory +import System.IO +import System.Process (ProcessHandle()) +#ifndef mingw32_HOST_OS +import System.Process (waitForProcess) +#endif +import System.Timeout + +-- | A session representing one instance of launching and connecting to a server. +-- +-- You can send and receive messages to the server within 'Session' via +-- 'Language.LSP.Test.message', +-- 'Language.LSP.Test.sendRequest' and +-- 'Language.LSP.Test.sendNotification'. + +newtype Session a = Session (ConduitParser FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) a) + deriving (Functor, Applicative, Monad, MonadIO, Alternative) + +#if __GLASGOW_HASKELL__ >= 806 +instance MonadFail Session where + fail s = do + lastMsg <- fromJust . lastReceivedMessage <$> get + liftIO $ throw (UnexpectedMessage s lastMsg) +#endif + +-- | Stuff you can configure for a 'Session'. +data SessionConfig = SessionConfig + { messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds, defaults to 60. + , logStdErr :: Bool + -- ^ Redirect the server's stderr to this stdout, defaults to False. + -- Can be overriden with @LSP_TEST_LOG_STDERR@. + , logMessages :: Bool + -- ^ Trace the messages sent and received to stdout, defaults to False. + -- Can be overriden with the environment variable @LSP_TEST_LOG_MESSAGES@. + , logColor :: Bool -- ^ Add ANSI color to the logged messages, defaults to True. + , lspConfig :: Maybe Value -- ^ The initial LSP config as JSON value, defaults to Nothing. + , ignoreLogNotifications :: Bool + -- ^ Whether or not to ignore 'Language.LSP.Types.ShowMessageNotification' and + -- 'Language.LSP.Types.LogMessageNotification', defaults to False. + -- + -- @since 0.9.0.0 + , initialWorkspaceFolders :: Maybe [WorkspaceFolder] + -- ^ The initial workspace folders to send in the @initialize@ request. + -- Defaults to Nothing. + } + +-- | The configuration used in 'Language.LSP.Test.runSession'. +defaultConfig :: SessionConfig +defaultConfig = SessionConfig 60 False False True Nothing False Nothing + +instance Default SessionConfig where + def = defaultConfig + +data SessionMessage = ServerMessage FromServerMessage + | TimeoutMessage Int + deriving Show + +data SessionContext = SessionContext + { + serverIn :: Handle + , rootDir :: FilePath + , messageChan :: Chan SessionMessage -- ^ Where all messages come through + -- Keep curTimeoutId in SessionContext, as its tied to messageChan + , curTimeoutId :: MVar Int -- ^ The current timeout we are waiting on + , requestMap :: MVar RequestMap + , initRsp :: MVar (ResponseMessage Initialize) + , config :: SessionConfig + , sessionCapabilities :: ClientCapabilities + } + +class Monad m => HasReader r m where + ask :: m r + asks :: (r -> b) -> m b + asks f = f <$> ask + +instance HasReader SessionContext Session where + ask = Session (lift $ lift Reader.ask) + +instance Monad m => HasReader r (ConduitM a b (StateT s (ReaderT r m))) where + ask = lift $ lift Reader.ask + +getCurTimeoutId :: (HasReader SessionContext m, MonadIO m) => m Int +getCurTimeoutId = asks curTimeoutId >>= liftIO . readMVar + +-- Pass this the timeoutid you *were* waiting on +bumpTimeoutId :: (HasReader SessionContext m, MonadIO m) => Int -> m () +bumpTimeoutId prev = do + v <- asks curTimeoutId + -- when updating the curtimeoutid, account for the fact that something else + -- might have bumped the timeoutid in the meantime + liftIO $ modifyMVar_ v (\x -> pure (max x (prev + 1))) + +data SessionState = SessionState + { + curReqId :: Int + , vfs :: VFS + , curDiagnostics :: Map.Map NormalizedUri [Diagnostic] + , overridingTimeout :: Bool + -- ^ The last received message from the server. + -- Used for providing exception information + , lastReceivedMessage :: Maybe FromServerMessage + , curDynCaps :: Map.Map T.Text SomeRegistration + -- ^ The capabilities that the server has dynamically registered with us so + -- far + , curProgressSessions :: Set.Set ProgressToken + } + +class Monad m => HasState s m where + get :: m s + + put :: s -> m () + + modify :: (s -> s) -> m () + modify f = get >>= put . f + + modifyM :: (HasState s m, Monad m) => (s -> m s) -> m () + modifyM f = get >>= f >>= put + +instance HasState SessionState Session where + get = Session (lift State.get) + put = Session . lift . State.put + +instance Monad m => HasState s (StateT s m) where + get = State.get + put = State.put + +instance (Monad m, (HasState s m)) => HasState s (ConduitM a b m) + where + get = lift get + put = lift . put + +instance (Monad m, (HasState s m)) => HasState s (ConduitParser a m) + where + get = lift get + put = lift . put + +runSessionMonad :: SessionContext -> SessionState -> Session a -> IO (a, SessionState) +runSessionMonad context state (Session session) = runReaderT (runStateT conduit state) context + where + conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler) + + handler (Unexpected "ConduitParser.empty") = do + lastMsg <- fromJust . lastReceivedMessage <$> get + name <- getParserName + liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg) + + handler e = throw e + + chanSource = do + msg <- liftIO $ readChan (messageChan context) + unless (ignoreLogNotifications (config context) && isLogNotification msg) $ + yield msg + chanSource + + isLogNotification (ServerMessage (FromServerMess SWindowShowMessage _)) = True + isLogNotification (ServerMessage (FromServerMess SWindowLogMessage _)) = True + isLogNotification _ = False + + watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () + watchdog = Conduit.awaitForever $ \msg -> do + curId <- getCurTimeoutId + case msg of + ServerMessage sMsg -> yield sMsg + TimeoutMessage tId -> when (curId == tId) $ lastReceivedMessage <$> get >>= throw . Timeout + +-- | 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. +runSession' :: Handle -- ^ Server in + -> Handle -- ^ Server out + -> Maybe ProcessHandle -- ^ Server process + -> (Handle -> SessionContext -> IO ()) -- ^ Server listener + -> SessionConfig + -> ClientCapabilities + -> FilePath -- ^ Root directory + -> Session () -- ^ To exit the Server properly + -> Session a + -> IO a +runSession' serverIn serverOut mServerProc serverHandler config caps rootDir exitServer session = do + absRootDir <- canonicalizePath rootDir + + hSetBuffering serverIn NoBuffering + hSetBuffering serverOut NoBuffering + -- This is required to make sure that we don’t get any + -- newline conversion or weird encoding issues. + hSetBinaryMode serverIn True + hSetBinaryMode serverOut True + + reqMap <- newMVar newRequestMap + messageChan <- newChan + timeoutIdVar <- newMVar 0 + initRsp <- newEmptyMVar + + mainThreadId <- myThreadId + + let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps + initState vfs = SessionState 0 vfs mempty False Nothing mempty mempty + runSession' ses = initVFS $ \vfs -> runSessionMonad context (initState vfs) ses + + errorHandler = throwTo mainThreadId :: SessionException -> IO () + serverListenerLauncher = + forkIO $ catch (serverHandler serverOut context) errorHandler + msgTimeoutMs = messageTimeout config * 10^6 + serverAndListenerFinalizer tid = do + let cleanup + | Just sp <- mServerProc = do + -- 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 sp) +#endif + cleanupProcess (Just serverIn, Just serverOut, Nothing, sp) + | otherwise = pure () + finally (timeout msgTimeoutMs (runSession' exitServer)) + -- Make sure to kill the listener first, before closing + -- handles etc via cleanupProcess + (killThread tid >> cleanup) + + (result, _) <- bracket serverListenerLauncher + serverAndListenerFinalizer + (const $ initVFS $ \vfs -> runSessionMonad context (initState vfs) session) + return result + +updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () +updateStateC = awaitForever $ \msg -> do + updateState msg + respond msg + yield msg + where + respond :: (MonadIO m, HasReader SessionContext m) => FromServerMessage -> m () + respond (FromServerMess SWindowWorkDoneProgressCreate req) = + sendMessage $ ResponseMessage "2.0" (Just $ req ^. LSP.id) (Right ()) + respond (FromServerMess SWorkspaceApplyEdit r) = do + sendMessage $ ResponseMessage "2.0" (Just $ r ^. LSP.id) (Right $ ApplyWorkspaceEditResponseBody True Nothing) + respond _ = pure () + + +-- extract Uri out from DocumentChange +-- didn't put this in `lsp-types` because TH was getting in the way +documentChangeUri :: DocumentChange -> Uri +documentChangeUri (InL x) = x ^. textDocument . uri +documentChangeUri (InR (InL x)) = x ^. uri +documentChangeUri (InR (InR (InL x))) = x ^. oldUri +documentChangeUri (InR (InR (InR x))) = x ^. uri + +updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) + => FromServerMessage -> m () +updateState (FromServerMess SProgress req) = case req ^. params . value of + Begin _ -> + modify $ \s -> s { curProgressSessions = Set.insert (req ^. params . token) $ curProgressSessions s } + End _ -> + modify $ \s -> s { curProgressSessions = Set.delete (req ^. params . token) $ curProgressSessions s } + _ -> pure () + +-- Keep track of dynamic capability registration +updateState (FromServerMess SClientRegisterCapability req) = do + let List newRegs = (\sr@(SomeRegistration r) -> (r ^. LSP.id, sr)) <$> req ^. params . registrations + modify $ \s -> + s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) } + +updateState (FromServerMess SClientUnregisterCapability req) = do + let List unRegs = (^. LSP.id) <$> req ^. params . unregisterations + modify $ \s -> + let newCurDynCaps = foldr' Map.delete (curDynCaps s) unRegs + in s { curDynCaps = newCurDynCaps } + +updateState (FromServerMess STextDocumentPublishDiagnostics n) = do + let List diags = n ^. params . diagnostics + doc = n ^. params . uri + modify $ \s -> + let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s) + in s { curDiagnostics = newDiags } + +updateState (FromServerMess SWorkspaceApplyEdit r) = do + + -- First, prefer the versioned documentChanges field + allChangeParams <- case r ^. params . edit . documentChanges of + Just (List cs) -> do + mapM_ (checkIfNeedsOpened . documentChangeUri) cs + return $ mapMaybe getParamsFromDocumentChange cs + -- Then fall back to the changes field + Nothing -> case r ^. params . edit . changes of + Just cs -> do + mapM_ checkIfNeedsOpened (HashMap.keys cs) + concat <$> mapM (uncurry getChangeParams) (HashMap.toList cs) + Nothing -> + error "WorkspaceEdit contains neither documentChanges nor changes!" + + modifyM $ \s -> do + newVFS <- liftIO $ changeFromServerVFS (vfs s) r + return $ s { vfs = newVFS } + + let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams + mergedParams = map mergeParams groupedParams + + -- TODO: Don't do this when replaying a session + forM_ mergedParams (sendMessage . NotificationMessage "2.0" STextDocumentDidChange) + + -- Update VFS to new document versions + let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams + latestVersions = map ((^. textDocument) . last) sortedVersions + bumpedVersions = map (version . _Just +~ 1) latestVersions + + forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) -> + modify $ \s -> + let oldVFS = vfs s + update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver + 1) t + newVFS = updateVFS (Map.adjust update (toNormalizedUri uri)) oldVFS + in s { vfs = newVFS } + + where checkIfNeedsOpened uri = do + oldVFS <- vfs <$> get + ctx <- ask + + -- if its not open, open it + unless (toNormalizedUri uri `Map.member` vfsMap oldVFS) $ do + let fp = fromJust $ uriToFilePath uri + contents <- liftIO $ T.readFile fp + let item = TextDocumentItem (filePathToUri fp) "" 0 contents + msg = NotificationMessage "2.0" STextDocumentDidOpen (DidOpenTextDocumentParams item) + liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg) + + modifyM $ \s -> do + let (newVFS,_) = openVFS (vfs s) msg + return $ s { vfs = newVFS } + + getParamsFromTextDocumentEdit :: TextDocumentEdit -> DidChangeTextDocumentParams + getParamsFromTextDocumentEdit (TextDocumentEdit docId (List edits)) = + let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits + in DidChangeTextDocumentParams docId (List changeEvents) + + getParamsFromDocumentChange :: DocumentChange -> Maybe DidChangeTextDocumentParams + getParamsFromDocumentChange (InL textDocumentEdit) = Just $ getParamsFromTextDocumentEdit textDocumentEdit + getParamsFromDocumentChange _ = Nothing + + + -- For a uri returns an infinite list of versions [n,n+1,n+2,...] + -- where n is the current version + textDocumentVersions uri = do + m <- vfsMap . vfs <$> get + let curVer = fromMaybe 0 $ + _lsp_version <$> m Map.!? (toNormalizedUri uri) + pure $ map (VersionedTextDocumentIdentifier uri . Just) [curVer + 1..] + + textDocumentEdits uri edits = do + vers <- textDocumentVersions uri + pure $ map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip vers edits + + getChangeParams uri (List edits) = do + map <$> pure getParamsFromTextDocumentEdit <*> textDocumentEdits uri (reverse edits) + + mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams + mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params)) + in DidChangeTextDocumentParams (head params ^. textDocument) (List events) +updateState _ = return () + +sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m () +sendMessage msg = do + h <- serverIn <$> ask + logMsg LogClient msg + liftIO $ B.hPut h (addHeader $ encode msg) + +-- | Execute a block f that will throw a 'Language.LSP.Test.Exception.Timeout' exception +-- after duration seconds. This will override the global timeout +-- for waiting for messages to arrive defined in 'SessionConfig'. +withTimeout :: Int -> Session a -> Session a +withTimeout duration f = do + chan <- asks messageChan + timeoutId <- getCurTimeoutId + modify $ \s -> s { overridingTimeout = True } + liftIO $ forkIO $ do + threadDelay (duration * 1000000) + writeChan chan (TimeoutMessage timeoutId) + res <- f + bumpTimeoutId timeoutId + modify $ \s -> s { overridingTimeout = False } + return res + +data LogMsgType = LogServer | LogClient + deriving Eq + +-- | Logs the message if the config specified it +logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m) + => LogMsgType -> a -> m () +logMsg t msg = do + shouldLog <- asks $ logMessages . config + shouldColor <- asks $ logColor . config + liftIO $ when shouldLog $ do + when shouldColor $ setSGR [SetColor Foreground Dull color] + putStrLn $ arrow ++ showPretty msg + when shouldColor $ setSGR [Reset] + + where arrow + | t == LogServer = "<-- " + | otherwise = "--> " + color + | t == LogServer = Magenta + | otherwise = Cyan + + showPretty = B.unpack . encodePretty diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} @@ -15,16 +17,16 @@ import Control.Monad.IO.Class import Control.Monad import Control.Lens hiding (List) -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens hiding +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Lens hiding (capabilities, message, rename, applyEdit) -import qualified Language.Haskell.LSP.Types.Lens as LSP -import Language.Haskell.LSP.Types.Capabilities as LSP +import qualified Language.LSP.Types.Lens as LSP +import Language.LSP.Types.Capabilities as LSP import System.Directory import System.FilePath import System.Timeout +import Data.Type.Equality {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-} @@ -51,7 +53,7 @@ -- won't receive a request - will timeout -- incoming logging requests shouldn't increase the -- timeout - withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest + withTimeout 5 $ skipManyTill anyMessage (message SWorkspaceApplyEdit) -- wait just a bit longer than 5 seconds so we have time -- to open the document in timeout 6000000 sesh `shouldThrow` anySessionException @@ -90,7 +92,7 @@ withTimeout 10 $ liftIO $ threadDelay 7000000 getDocumentSymbols doc -- should now timeout - skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest + skipManyTill anyMessage (message SWorkspaceApplyEdit) isTimeout (Timeout _) = True isTimeout _ = False in sesh `shouldThrow` isTimeout @@ -100,7 +102,7 @@ it "throw on time out" $ let sesh = runSessionWithConfig (def {messageTimeout = 10}) serverExe fullCaps "test/data/renamePass" $ do skipMany loggingNotification - _ <- message :: Session ApplyWorkspaceEditRequest + _ <- message SWorkspaceApplyEdit return () in sesh `shouldThrow` anySessionException @@ -112,52 +114,30 @@ describe "UnexpectedMessageException" $ do it "throws when there's an unexpected message" $ - let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True + let selector (UnexpectedMessage "Publish diagnostics notification" (FromServerMess SWindowLogMessage _)) = True selector _ = False in runSession serverExe fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector it "provides the correct types that were expected and received" $ - let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True + let selector (UnexpectedMessage "STextDocumentRename" (FromServerRsp STextDocumentDocumentSymbol _)) = True selector _ = False sesh = do doc <- openDoc "Desktop/simple.hs" "haskell" - sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) + sendRequest STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) skipMany anyNotification - message :: Session RenameResponse -- the wrong type + response STextDocumentRename -- the wrong type in runSession serverExe fullCaps "test/data/renamePass" sesh `shouldThrow` selector - -- This is too fickle at the moment - -- describe "replaySession" $ - -- it "passes a test" $ - -- replaySession serverExe "test/data/renamePass" - -- it "fails a test" $ - -- let selector (ReplayOutOfOrder _ _) = True - -- selector _ = False - -- in replaySession serverExe "test/data/renameFail" `shouldThrow` selector - - -- describe "manual javascript session" $ - -- it "passes a test" $ - -- runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do - -- doc <- openDoc "test.js" "javascript" - - -- noDiagnostics - - -- Right (fooSymbol:_) <- getDocumentSymbols doc - - -- liftIO $ do - -- fooSymbol ^. name `shouldBe` "foo" - -- fooSymbol ^. kind `shouldBe` SkFunction - describe "text document VFS" $ it "sends back didChange notifications" $ runSession serverExe def "test/data/refactor" $ do doc <- openDoc "Main.hs" "haskell" let args = toJSON (doc ^. uri) - reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing - request_ WorkspaceExecuteCommand reqParams + reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args])) + request_ SWorkspaceExecuteCommand reqParams - editReq <- message :: Session ApplyWorkspaceEditRequest + editReq <- message SWorkspaceApplyEdit liftIO $ do let (Just cs) = editReq ^. params . edit . changes [(u, List es)] = HM.toList cs @@ -172,8 +152,8 @@ doc <- openDoc "Main.hs" "haskell" let args = toJSON (doc ^. uri) - reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing - request_ WorkspaceExecuteCommand reqParams + reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args])) + request_ SWorkspaceExecuteCommand reqParams contents <- getDocumentEdit doc liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n" @@ -181,7 +161,7 @@ it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do doc <- openDoc "Main.hs" "haskell" waitForDiagnostics - [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18)) + [InR action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18)) liftIO $ action ^. title `shouldBe` "Delete this" describe "getAllCodeActions" $ @@ -190,9 +170,9 @@ _ <- waitForDiagnostics actions <- getAllCodeActions doc liftIO $ do - let [CACodeAction action] = actions + let [InR action] = actions action ^. title `shouldBe` "Delete this" - action ^. command . _Just . command `shouldBe` "deleteThis" + action ^. command . _Just . command `shouldBe` "deleteThis" describe "getDocumentSymbols" $ it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do @@ -311,7 +291,7 @@ describe "satisfy" $ it "works" $ runSession serverExe fullCaps "test/data" $ do openDoc "Format.hs" "haskell" - let pred (NotLogMessage _) = True + let pred (FromServerMess SWindowLogMessage _) = True pred _ = False void $ satisfy pred @@ -319,32 +299,34 @@ it "works" $ runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) serverExe fullCaps "test/data" $ do openDoc "Format.hs" "haskell" - void publishDiagnosticsNotification + void publishDiagnosticsNotification describe "dynamic capabilities" $ do + it "keeps track" $ runSession serverExe fullCaps "test/data" $ do loggingNotification -- initialized log message createDoc ".register" "haskell" "" - message :: Session RegisterCapabilityRequest + message SClientRegisterCapability doc <- createDoc "Foo.watch" "haskell" "" - NotLogMessage msg <- loggingNotification + msg <- message SWindowLogMessage liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles" - caps <- getRegisteredCapabilities - liftIO $ caps `shouldBe` - [ Registration "0" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $ - DidChangeWatchedFilesRegistrationOptions $ List - [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ] - ] + [SomeRegistration (Registration _ regMethod regOpts)] <- getRegisteredCapabilities + liftIO $ do + case regMethod `mEqClient` SWorkspaceDidChangeWatchedFiles of + Just HRefl -> + regOpts `shouldBe` (DidChangeWatchedFilesRegistrationOptions $ List + [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ]) + Nothing -> expectationFailure "Registration wasn't on workspace/didChangeWatchedFiles" -- now unregister it by sending a specific createDoc createDoc ".unregister" "haskell" "" - message :: Session UnregisterCapabilityRequest + message SClientUnregisterCapability createDoc "Bar.watch" "haskell" "" - void $ sendRequest TextDocumentHover $ TextDocumentPositionParams doc (Position 0 0) Nothing + void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing count 0 $ loggingNotification void $ anyResponse @@ -354,25 +336,22 @@ loggingNotification -- initialized log message createDoc ".register.abs" "haskell" "" - message :: Session RegisterCapabilityRequest + message SClientRegisterCapability doc <- createDoc (curDir "Foo.watch") "haskell" "" - NotLogMessage msg <- loggingNotification + msg <- message SWindowLogMessage liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles" -- now unregister it by sending a specific createDoc createDoc ".unregister.abs" "haskell" "" - message :: Session UnregisterCapabilityRequest + message SClientUnregisterCapability createDoc (curDir "Bar.watch") "haskell" "" - void $ sendRequest TextDocumentHover $ TextDocumentPositionParams doc (Position 0 0) Nothing + void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing count 0 $ loggingNotification void $ anyResponse -mkRange :: Int -> Int -> Int -> Int -> Range -mkRange sl sc el ec = Range (Position sl sc) (Position el ec) - didChangeCaps :: ClientCapabilities didChangeCaps = def { _workspace = Just workspaceCaps } where @@ -383,7 +362,7 @@ docChangesCaps = def { _workspace = Just workspaceCaps } where workspaceCaps = def { _workspaceEdit = Just editCaps } - editCaps = WorkspaceEditClientCapabilities (Just True) + editCaps = WorkspaceEditClientCapabilities (Just True) Nothing Nothing findExeRecursive :: FilePath -> FilePath -> IO (Maybe FilePath) diff --git a/test/dummy-server/Main.hs b/test/dummy-server/Main.hs --- a/test/dummy-server/Main.hs +++ b/test/dummy-server/Main.hs @@ -1,122 +1,173 @@ +{-# LANGUAGE TypeInType #-} {-# LANGUAGE OverloadedStrings #-} -import Data.Aeson -import Data.Default -import Data.List (isSuffixOf) -import qualified Data.HashMap.Strict as HM -import Language.Haskell.LSP.Core -import Language.Haskell.LSP.Control -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types -import Control.Concurrent + import Control.Monad +import Control.Monad.Reader +import Data.Aeson hiding (defaultOptions) +import qualified Data.HashMap.Strict as HM +import Data.List (isSuffixOf) +import Data.String +import Language.LSP.Server +import Language.LSP.Types import System.Directory import System.FilePath +import UnliftIO +import UnliftIO.Concurrent main = do - lfvar <- newEmptyMVar - let initCbs = InitializeCallbacks - { onInitialConfiguration = const $ Right () - , onConfigurationChange = const $ Right () - , onStartup = \lf -> do - putMVar lfvar lf - - return Nothing - } - options = def - { executeCommandCommands = Just ["doAnEdit"] - } - run initCbs (handlers lfvar) options Nothing - -handlers :: MVar (LspFuncs ()) -> Handlers -handlers lfvar = def - { initializedHandler = pure $ \_ -> send $ NotLogMessage $ fmServerLogMessageNotification MtLog "initialized" - , hoverHandler = pure $ \req -> send $ - RspHover $ makeResponseMessage req (Just (Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing)) - , documentSymbolHandler = pure $ \req -> send $ - RspDocumentSymbols $ makeResponseMessage req $ DSDocumentSymbols $ - List [ DocumentSymbol "foo" - Nothing - SkObject - Nothing - (mkRange 0 0 3 6) - (mkRange 0 0 3 6) - Nothing - ] - , didOpenTextDocumentNotificationHandler = pure $ \noti -> do - let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti - TextDocumentItem uri _ _ _ = doc - Just fp = uriToFilePath uri - diag = Diagnostic (mkRange 0 0 0 1) - (Just DsWarning) - (Just (NumberValue 42)) - (Just "dummy-server") - "Here's a warning" - Nothing - Nothing - when (".hs" `isSuffixOf` fp) $ void $ forkIO $ do - threadDelay (2 * 10^6) - send $ NotPublishDiagnostics $ - fmServerPublishDiagnosticsNotification $ PublishDiagnosticsParams uri $ List [diag] - - -- also act as a registerer for workspace/didChangeWatchedFiles - when (".register" `isSuffixOf` fp) $ do - reqId <- readMVar lfvar >>= getNextReqId - send $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest reqId $ - RegistrationParams $ List $ - [ Registration "0" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $ - DidChangeWatchedFilesRegistrationOptions $ List - [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ] - ] - when (".register.abs" `isSuffixOf` fp) $ do - curDir <- getCurrentDirectory - reqId <- readMVar lfvar >>= getNextReqId - send $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest reqId $ - RegistrationParams $ List $ - [ Registration "1" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $ - DidChangeWatchedFilesRegistrationOptions $ List - [ FileSystemWatcher (curDir "*.watch") (Just (WatchKind True True True)) ] - ] + handlerEnv <- HandlerEnv <$> newEmptyMVar <*> newEmptyMVar + runServer $ ServerDefinition + { doInitialize = \env _req -> pure $ Right env, + onConfigurationChange = const $ pure $ Right (), + staticHandlers = handlers, + interpretHandler = \env -> + Iso + (\m -> runLspT env (runReaderT m handlerEnv)) + liftIO, + options = defaultOptions {executeCommandCommands = Just ["doAnEdit"]} + } - -- also act as an unregisterer for workspace/didChangeWatchedFiles - when (".unregister" `isSuffixOf` fp) $ do - reqId <- readMVar lfvar >>= getNextReqId - send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $ - UnregistrationParams $ List [ Unregistration "0" "workspace/didChangeWatchedFiles" ] - when (".unregister.abs" `isSuffixOf` fp) $ do - reqId <- readMVar lfvar >>= getNextReqId - send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $ - UnregistrationParams $ List [ Unregistration "1" "workspace/didChangeWatchedFiles" ] - , executeCommandHandler = pure $ \req -> do - send $ RspExecuteCommand $ makeResponseMessage req Null - reqId <- readMVar lfvar >>= getNextReqId - let RequestMessage _ _ _ (ExecuteCommandParams "doAnEdit" (Just (List [val])) _) = req - Success docUri = fromJSON val - edit = List [TextEdit (mkRange 0 0 0 5) "howdy"] - send $ ReqApplyWorkspaceEdit $ fmServerApplyWorkspaceEditRequest reqId $ - ApplyWorkspaceEditParams $ WorkspaceEdit (Just (HM.singleton docUri edit)) - Nothing - , codeActionHandler = pure $ \req -> do - let RequestMessage _ _ _ params = req - CodeActionParams _ _ cactx _ = params - CodeActionContext diags _ = cactx - caresults = fmap diag2caresult diags - diag2caresult d = CACodeAction $ - CodeAction "Delete this" - Nothing - (Just (List [d])) - Nothing - (Just (Command "" "deleteThis" Nothing)) - send $ RspCodeAction $ makeResponseMessage req caresults - , didChangeWatchedFilesNotificationHandler = pure $ \_ -> - send $ NotLogMessage $ fmServerLogMessageNotification MtLog "got workspace/didChangeWatchedFiles" - , completionHandler = pure $ \req -> do - let res = CompletionList (CompletionListType False (List [item])) - item = - CompletionItem "foo" (Just CiConstant) (Just (List [])) Nothing - Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing - send $ RspCompletion $ makeResponseMessage req res +data HandlerEnv = HandlerEnv + { relRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles), + absRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles) } - where send msg = readMVar lfvar >>= \lf -> (sendFunc lf) msg -mkRange sl sc el ec = Range (Position sl sc) (Position el ec) +handlers :: Handlers (ReaderT HandlerEnv (LspM ())) +handlers = + mconcat + [ notificationHandler SInitialized $ + \_noti -> + sendNotification SWindowLogMessage $ + LogMessageParams MtLog "initialized" + , requestHandler STextDocumentHover $ + \_req responder -> + responder $ + Right $ + Just $ + Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing + , requestHandler STextDocumentDocumentSymbol $ + \_req responder -> + responder $ + Right $ + InL $ + List + [ DocumentSymbol + "foo" + Nothing + SkObject + Nothing + (mkRange 0 0 3 6) + (mkRange 0 0 3 6) + Nothing + ] + , notificationHandler STextDocumentDidOpen $ + \noti -> do + let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti + TextDocumentItem uri _ _ _ = doc + Just fp = uriToFilePath uri + diag = + Diagnostic + (mkRange 0 0 0 1) + (Just DsWarning) + (Just (InL 42)) + (Just "dummy-server") + "Here's a warning" + Nothing + Nothing + withRunInIO $ + \runInIO -> do + when (".hs" `isSuffixOf` fp) $ + void $ + forkIO $ + do + threadDelay (2 * 10 ^ 6) + runInIO $ + sendNotification STextDocumentPublishDiagnostics $ + PublishDiagnosticsParams uri Nothing (List [diag]) + -- also act as a registerer for workspace/didChangeWatchedFiles + when (".register" `isSuffixOf` fp) $ + do + let regOpts = + DidChangeWatchedFilesRegistrationOptions $ + List + [ FileSystemWatcher + "*.watch" + (Just (WatchKind True True True)) + ] + Just token <- runInIO $ + registerCapability SWorkspaceDidChangeWatchedFiles regOpts $ + \_noti -> + sendNotification SWindowLogMessage $ + LogMessageParams MtLog "got workspace/didChangeWatchedFiles" + runInIO $ asks relRegToken >>= \v -> putMVar v token + when (".register.abs" `isSuffixOf` fp) $ + do + curDir <- getCurrentDirectory + let regOpts = + DidChangeWatchedFilesRegistrationOptions $ + List + [ FileSystemWatcher + (fromString $ curDir "*.watch") + (Just (WatchKind True True True)) + ] + Just token <- runInIO $ + registerCapability SWorkspaceDidChangeWatchedFiles regOpts $ + \_noti -> + sendNotification SWindowLogMessage $ + LogMessageParams MtLog "got workspace/didChangeWatchedFiles" + runInIO $ asks absRegToken >>= \v -> putMVar v token + -- also act as an unregisterer for workspace/didChangeWatchedFiles + when (".unregister" `isSuffixOf` fp) $ + do + Just token <- runInIO $ asks relRegToken >>= tryReadMVar + runInIO $ unregisterCapability token + when (".unregister.abs" `isSuffixOf` fp) $ + do + Just token <- runInIO $ asks absRegToken >>= tryReadMVar + runInIO $ unregisterCapability token + , requestHandler SWorkspaceExecuteCommand $ \req resp -> do + let RequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just (List [val]))) = req + Success docUri = fromJSON val + edit = List [TextEdit (mkRange 0 0 0 5) "howdy"] + params = + ApplyWorkspaceEditParams (Just "Howdy edit") $ + WorkspaceEdit (Just (HM.singleton docUri edit)) Nothing + resp $ Right Null + void $ sendRequest SWorkspaceApplyEdit params (const (pure ())) + , requestHandler STextDocumentCodeAction $ \req resp -> do + let RequestMessage _ _ _ params = req + CodeActionParams _ _ _ _ cactx = params + CodeActionContext diags _ = cactx + codeActions = fmap diag2ca diags + diag2ca d = + CodeAction + "Delete this" + Nothing + (Just (List [d])) + Nothing + Nothing + Nothing + (Just (Command "" "deleteThis" Nothing)) + resp $ Right $ InR <$> codeActions + , requestHandler STextDocumentCompletion $ \_req resp -> do + let res = CompletionList True (List [item]) + item = + CompletionItem + "foo" + (Just CiConstant) + (Just (List [])) + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + resp $ Right $ InR res + ]