{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeInType #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE DuplicateRecordFields #-}
{-|
Module : Language.LSP.Test
, waitForDiagnosticsSource
, noDiagnostics
, getCurrentDiagnostics
+ , getIncompleteProgressSessions
-- ** Commands
, executeCommand
-- ** Code Actions
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
-- > diags <- waitForDiagnostics
-- > let pos = Position 12 5
-- > params = TextDocumentPositionParams doc
--- > hover <- request TextDocumentHover params
+-- > 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.
-- | Starts a new session, using the specified handles to communicate with the
-- server. You can use this to host the server within the same process.
--- An example with haskell-lsp might look like:
+-- An example with lsp might look like:
--
-- > (hinRead, hinWrite) <- createPipe
-- > (houtRead, houtWrite) <- createPipe
-- >
--- > forkIO $ void $ runWithHandles hinRead houtWrite initCallbacks handlers def
--- > Test.runSessionWithHandles hinWrite houtRead defaultConfig fullCaps "." $ do
+-- > forkIO $ void $ runServerWithHandles hinRead houtWrite serverDefinition
+-- > runSessionWithHandles hinWrite houtRead defaultConfig fullCaps "." $ do
-- > -- ...
runSessionWithHandles :: Handle -- ^ The input handle
-> Handle -- ^ The output handle
(List <$> initialWorkspaceFolders config)
runSession' serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do
-- Wrap the session around initialize and shutdown calls
- -- initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
initReqId <- sendRequest SInitialize initializeParams
-- Because messages can be sent in between the request and response,
documentContents doc
where
- checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
checkDocumentChanges req =
let changes = req ^. params . edit . documentChanges
- maybeDocs = fmap (fmap (^. textDocument . uri)) changes
+ maybeDocs = fmap (fmap documentChangeUri) 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
+-- rsp <- request STextDocumentDocumentSymbol params
-- @
-- Note: will skip any messages in between the request and the response.
request :: SClientMethod m -> MessageParams m -> Session (ResponseMessage m)
-- | 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)
+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
--
-- @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 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
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 (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
-- | Opens a text document that /exists on disk/, and sends a
-- textDocument/didOpen notification to the server.
-openDoc :: FilePath -> String -> Session TextDocumentIdentifier
+openDoc :: FilePath -> T.Text -> Session TextDocumentIdentifier
openDoc file languageId = do
context <- ask
let fp = rootDir context </> file
-- | 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' :: 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 (T.pack languageId) 0 contents
+ item = TextDocumentItem uri languageId 0 contents
sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams item)
pure $ TextDocumentIdentifier uri
-- | Returns the symbols in a document.
getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
getDocumentSymbols doc = do
- ResponseMessage _ rspLid res <- request STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) :: Session DocumentSymbolsResponse
+ 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)
-- | Returns the code actions in the specified range.
getCodeActions :: TextDocumentIdentifier -> Range -> Session [Command |? CodeAction]
getCodeActions doc range = do
- ctx <- getCodeActionContext doc
+ ctx <- getCodeActionContextInRange doc range
rsp <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc range ctx)
case rsp ^. result of
Left e -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) e)
Right (List cmdOrCAs) -> pure (acc ++ cmdOrCAs)
+getCodeActionContextInRange :: TextDocumentIdentifier -> Range -> Session CodeActionContext
+getCodeActionContextInRange doc caRange = do
+ curDiags <- getCurrentDiagnostics doc
+ let diags = [ d | d@Diagnostic{_range=range} <- curDiags
+ , overlappingRange caRange range
+ ]
+ return $ CodeActionContext (List diags) Nothing
+ where
+ overlappingRange :: Range -> Range -> Bool
+ overlappingRange (Range s e) range =
+ positionInRange s range
+ || positionInRange e range
+
+ positionInRange :: Position -> Range -> Bool
+ positionInRange (Position pl po) (Range (Position sl so) (Position el eo)) =
+ pl > sl && pl < el
+ || pl == sl && pl == el && po >= so && po <= eo
+ || pl == sl && po >= so
+ || pl == el && po <= eo
+
getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
getCodeActionContext doc = do
curDiags <- getCurrentDiagnostics doc
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 wEdit = if supportsDocChanges
then
let docEdit = TextDocumentEdit verDoc (List [edit])
- in WorkspaceEdit Nothing (Just (List [docEdit]))
+ in WorkspaceEdit Nothing (Just (List [InL docEdit]))
else
let changes = HashMap.singleton (doc ^. uri) (List [edit])
in WorkspaceEdit (Just changes) Nothing
rename :: TextDocumentIdentifier -> Position -> String -> Session ()
rename doc pos newName = do
let params = RenameParams doc pos Nothing (T.pack newName)
- rsp <- request STextDocumentRename params :: Session RenameResponse
+ rsp <- request STextDocumentRename params
let wEdit = getResponseResult rsp
req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)
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) :: Session CodeLensResponse
+ rsp <- request STextDocumentCodeLens (CodeLensParams Nothing Nothing tId)
case getResponseResult rsp of
List res -> pure res
--
-- @since 0.11.0.0
getRegisteredCapabilities :: Session [SomeRegistration]
-getRegisteredCapabilities = (Map.elems . curDynCaps) <$> get
+getRegisteredCapabilities = Map.elems . curDynCaps <$> get
projects / lsp-test.git / blobdiff