src/Language/LSP/Test.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE TypeOperators #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE KindSignatures #-}
   5 {-# LANGUAGE GADTs #-}
   6 {-# LANGUAGE RankNTypes #-}
   7 {-# LANGUAGE TypeInType #-}
   8 {-# LANGUAGE ScopedTypeVariables #-}
   9 {-# LANGUAGE ExistentialQuantification #-}
  10
  11 {-|
  12 Module      : Language.LSP.Test
  13 Description : A functional testing framework for LSP servers.
  14 Maintainer  : luke_lau@icloud.com
  15 Stability   : experimental
  16 Portability : non-portable
  17
  18 Provides the framework to start functionally testing
  19 <https://github.com/Microsoft/language-server-protocol Language Server Protocol servers>.
  20 You should import "Language.LSP.Types" alongside this.
  21 -}
  22 module Language.LSP.Test
  23   (
  24   -- * Sessions
  25     Session
  26   , runSession
  27   , runSessionWithConfig
  28   , runSessionWithHandles
  29   -- ** Config
  30   , SessionConfig(..)
  31   , defaultConfig
  32   , C.fullCaps
  33   -- ** Exceptions
  34   , module Language.LSP.Test.Exceptions
  35   , withTimeout
  36   -- * Sending
  37   , request
  38   , request_
  39   , sendRequest
  40   , sendNotification
  41   , sendResponse
  42   -- * Receving
  43   , module Language.LSP.Test.Parsing
  44   -- * Utilities
  45   -- | Quick helper functions for common tasks.
  46
  47   -- ** Initialization
  48   , initializeResponse
  49   -- ** Documents
  50   , createDoc
  51   , openDoc
  52   , closeDoc
  53   , changeDoc
  54   , documentContents
  55   , getDocumentEdit
  56   , getDocUri
  57   , getVersionedDoc
  58   -- ** Symbols
  59   , getDocumentSymbols
  60   -- ** Diagnostics
  61   , waitForDiagnostics
  62   , waitForDiagnosticsSource
  63   , noDiagnostics
  64   , getCurrentDiagnostics
  65   , getIncompleteProgressSessions
  66   -- ** Commands
  67   , executeCommand
  68   -- ** Code Actions
  69   , getCodeActions
  70   , getAllCodeActions
  71   , executeCodeAction
  72   -- ** Completions
  73   , getCompletions
  74   -- ** References
  75   , getReferences
  76   -- ** Definitions
  77   , getDeclarations
  78   , getDefinitions
  79   , getTypeDefinitions
  80   , getImplementations
  81   -- ** Renaming
  82   , rename
  83   -- ** Hover
  84   , getHover
  85   -- ** Highlights
  86   , getHighlights
  87   -- ** Formatting
  88   , formatDoc
  89   , formatRange
  90   -- ** Edits
  91   , applyEdit
  92   -- ** Code lenses
  93   , getCodeLenses
  94   -- ** Capabilities
  95   , getRegisteredCapabilities
  96   ) where
  97
  98 import Control.Applicative.Combinators
  99 import Control.Concurrent
 100 import Control.Monad
 101 import Control.Monad.IO.Class
 102 import Control.Exception
 103 import Control.Lens hiding ((.=), List, Empty)
 104 import qualified Data.Map.Strict as Map
 105 import qualified Data.Set as Set
 106 import qualified Data.Text as T
 107 import qualified Data.Text.IO as T
 108 import Data.Aeson
 109 import Data.Default
 110 import qualified Data.HashMap.Strict as HashMap
 111 import Data.List
 112 import Data.Maybe
 113 import Language.LSP.Types
 114 import Language.LSP.Types.Lens hiding
 115   (id, capabilities, message, executeCommand, applyEdit, rename)
 116 import qualified Language.LSP.Types.Lens as LSP
 117 import qualified Language.LSP.Types.Capabilities as C
 118 import Language.LSP.VFS
 119 import Language.LSP.Test.Compat
 120 import Language.LSP.Test.Decoding
 121 import Language.LSP.Test.Exceptions
 122 import Language.LSP.Test.Parsing
 123 import Language.LSP.Test.Session
 124 import Language.LSP.Test.Server
 125 import System.Environment
 126 import System.IO
 127 import System.Directory
 128 import System.FilePath
 129 import System.Process (ProcessHandle)
 130 import qualified System.FilePath.Glob as Glob
 131
 132 -- | Starts a new session.
 133 --
 134 -- > runSession "hie" fullCaps "path/to/root/dir" $ do
 135 -- >   doc <- openDoc "Desktop/simple.hs" "haskell"
 136 -- >   diags <- waitForDiagnostics
 137 -- >   let pos = Position 12 5
 138 -- >       params = TextDocumentPositionParams doc
 139 -- >   hover <- request STextdocumentHover params
 140 runSession :: String -- ^ The command to run the server.
 141            -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
 142            -> FilePath -- ^ The filepath to the root directory for the session.
 143            -> Session a -- ^ The session to run.
 144            -> IO a
 145 runSession = runSessionWithConfig def
 146
 147 -- | Starts a new sesion with a custom configuration.
 148 runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session.
 149                      -> String -- ^ The command to run the server.
 150                      -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
 151                      -> FilePath -- ^ The filepath to the root directory for the session.
 152                      -> Session a -- ^ The session to run.
 153                      -> IO a
 154 runSessionWithConfig config' serverExe caps rootDir session = do
 155   config <- envOverrideConfig config'
 156   withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc ->
 157     runSessionWithHandles' (Just serverProc) serverIn serverOut config caps rootDir session
 158
 159 -- | Starts a new session, using the specified handles to communicate with the
 160 -- server. You can use this to host the server within the same process.
 161 -- An example with lsp might look like:
 162 --
 163 -- > (hinRead, hinWrite) <- createPipe
 164 -- > (houtRead, houtWrite) <- createPipe
 165 -- >
 166 -- > forkIO $ void $ runServerWithHandles hinRead houtWrite serverDefinition
 167 -- > runSessionWithHandles hinWrite houtRead defaultConfig fullCaps "." $ do
 168 -- >   -- ...
 169 runSessionWithHandles :: Handle -- ^ The input handle
 170                       -> Handle -- ^ The output handle
 171                       -> SessionConfig
 172                       -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
 173                       -> FilePath -- ^ The filepath to the root directory for the session.
 174                       -> Session a -- ^ The session to run.
 175                       -> IO a
 176 runSessionWithHandles = runSessionWithHandles' Nothing
 177
 178
 179 runSessionWithHandles' :: Maybe ProcessHandle
 180                        -> Handle -- ^ The input handle
 181                        -> Handle -- ^ The output handle
 182                        -> SessionConfig
 183                        -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
 184                        -> FilePath -- ^ The filepath to the root directory for the session.
 185                        -> Session a -- ^ The session to run.
 186                        -> IO a
 187 runSessionWithHandles' serverProc serverIn serverOut config' caps rootDir session = do
 188   pid <- getCurrentProcessID
 189   absRootDir <- canonicalizePath rootDir
 190
 191   config <- envOverrideConfig config'
 192
 193   let initializeParams = InitializeParams Nothing
 194                                           (Just pid)
 195                                           (Just lspTestClientInfo)
 196                                           (Just $ T.pack absRootDir)
 197                                           (Just $ filePathToUri absRootDir)
 198                                           Nothing
 199                                           caps
 200                                           (Just TraceOff)
 201                                           (List <$> initialWorkspaceFolders config)
 202   runSession' serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do
 203     -- Wrap the session around initialize and shutdown calls
 204     initReqId <- sendRequest SInitialize initializeParams
 205
 206     -- Because messages can be sent in between the request and response,
 207     -- collect them and then...
 208     (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId SInitialize initReqId)
 209
 210     case initRspMsg ^. LSP.result of
 211       Left error -> liftIO $ putStrLn ("Error while initializing: " ++ show error)
 212       Right _ -> pure ()
 213
 214     initRspVar <- initRsp <$> ask
 215     liftIO $ putMVar initRspVar initRspMsg
 216     sendNotification SInitialized (Just InitializedParams)
 217
 218     case lspConfig config of
 219       Just cfg -> sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)
 220       Nothing -> return ()
 221
 222     -- ... relay them back to the user Session so they can match on them!
 223     -- As long as they are allowed.
 224     forM_ inBetween checkLegalBetweenMessage
 225     msgChan <- asks messageChan
 226     liftIO $ writeList2Chan msgChan (ServerMessage <$> inBetween)
 227
 228     -- Run the actual test
 229     session
 230   where
 231   -- | Asks the server to shutdown and exit politely
 232   exitServer :: Session ()
 233   exitServer = request_ SShutdown Empty >> sendNotification SExit Empty
 234
 235   -- | Listens to the server output until the shutdown ack,
 236   -- makes sure it matches the record and signals any semaphores
 237   listenServer :: Handle -> SessionContext -> IO ()
 238   listenServer serverOut context = do
 239     msgBytes <- getNextMessage serverOut
 240
 241     msg <- modifyMVar (requestMap context) $ \reqMap ->
 242       pure $ decodeFromServerMsg reqMap msgBytes
 243     writeChan (messageChan context) (ServerMessage msg)
 244
 245     case msg of
 246       (FromServerRsp SShutdown _) -> return ()
 247       _                           -> listenServer serverOut context
 248
 249   -- | Is this message allowed to be sent by the server between the intialize
 250   -- request and response?
 251   -- https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#initialize
 252   checkLegalBetweenMessage :: FromServerMessage -> Session ()
 253   checkLegalBetweenMessage (FromServerMess SWindowShowMessage _) = pure ()
 254   checkLegalBetweenMessage (FromServerMess SWindowLogMessage _) = pure ()
 255   checkLegalBetweenMessage (FromServerMess STelemetryEvent _) = pure ()
 256   checkLegalBetweenMessage (FromServerMess SWindowShowMessageRequest _) = pure ()
 257   checkLegalBetweenMessage msg = throw (IllegalInitSequenceMessage msg)
 258
 259 -- | Check environment variables to override the config
 260 envOverrideConfig :: SessionConfig -> IO SessionConfig
 261 envOverrideConfig cfg = do
 262   logMessages' <- fromMaybe (logMessages cfg) <$> checkEnv "LSP_TEST_LOG_MESSAGES"
 263   logStdErr' <- fromMaybe (logStdErr cfg) <$> checkEnv "LSP_TEST_LOG_STDERR"
 264   return $ cfg { logMessages = logMessages', logStdErr = logStdErr' }
 265   where checkEnv :: String -> IO (Maybe Bool)
 266         checkEnv s = fmap convertVal <$> lookupEnv s
 267         convertVal "0" = False
 268         convertVal _ = True
 269
 270 -- | The current text contents of a document.
 271 documentContents :: TextDocumentIdentifier -> Session T.Text
 272 documentContents doc = do
 273   vfs <- vfs <$> get
 274   let file = vfsMap vfs Map.! toNormalizedUri (doc ^. uri)
 275   return (virtualFileText file)
 276
 277 -- | Parses an ApplyEditRequest, checks that it is for the passed document
 278 -- and returns the new content
 279 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
 280 getDocumentEdit doc = do
 281   req <- message SWorkspaceApplyEdit
 282
 283   unless (checkDocumentChanges req || checkChanges req) $
 284     liftIO $ throw (IncorrectApplyEditRequest (show req))
 285
 286   documentContents doc
 287   where
 288     checkDocumentChanges req =
 289       let changes = req ^. params . edit . documentChanges
 290           maybeDocs = fmap (fmap documentChangeUri) changes
 291       in case maybeDocs of
 292         Just docs -> (doc ^. uri) `elem` docs
 293         Nothing -> False
 294     checkChanges req =
 295       let mMap = req ^. params . edit . changes
 296         in maybe False (HashMap.member (doc ^. uri)) mMap
 297
 298 -- | Sends a request to the server and waits for its response.
 299 -- Will skip any messages in between the request and the response
 300 -- @
 301 -- rsp <- request STextDocumentDocumentSymbol params
 302 -- @
 303 -- Note: will skip any messages in between the request and the response.
 304 request :: SClientMethod m -> MessageParams m -> Session (ResponseMessage m)
 305 request m = sendRequest m >=> skipManyTill anyMessage . responseForId m
 306
 307 -- | The same as 'sendRequest', but discard the response.
 308 request_ :: SClientMethod (m :: Method FromClient Request) -> MessageParams m -> Session ()
 309 request_ p = void . request p
 310
 311 -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
 312 sendRequest
 313   :: SClientMethod m -- ^ The request method.
 314   -> MessageParams m -- ^ The request parameters.
 315   -> Session (LspId m) -- ^ The id of the request that was sent.
 316 sendRequest method params = do
 317   idn <- curReqId <$> get
 318   modify $ \c -> c { curReqId = idn+1 }
 319   let id = IdInt idn
 320
 321   let mess = RequestMessage "2.0" id method params
 322
 323   -- Update the request map
 324   reqMap <- requestMap <$> ask
 325   liftIO $ modifyMVar_ reqMap $
 326     \r -> return $ fromJust $ updateRequestMap r id method
 327
 328   ~() <- case splitClientMethod method of
 329     IsClientReq -> sendMessage mess
 330     IsClientEither -> sendMessage $ ReqMess mess
 331
 332   return id
 333
 334 -- | Sends a notification to the server.
 335 sendNotification :: SClientMethod (m :: Method FromClient Notification) -- ^ The notification method.
 336                  -> MessageParams m -- ^ The notification parameters.
 337                  -> Session ()
 338 -- Open a virtual file if we send a did open text document notification
 339 sendNotification STextDocumentDidOpen params = do
 340   let n = NotificationMessage "2.0" STextDocumentDidOpen params
 341   oldVFS <- vfs <$> get
 342   let (newVFS,_) = openVFS oldVFS n
 343   modify (\s -> s { vfs = newVFS })
 344   sendMessage n
 345
 346 -- Close a virtual file if we send a close text document notification
 347 sendNotification STextDocumentDidClose params = do
 348   let n = NotificationMessage "2.0" STextDocumentDidClose params
 349   oldVFS <- vfs <$> get
 350   let (newVFS,_) = closeVFS oldVFS n
 351   modify (\s -> s { vfs = newVFS })
 352   sendMessage n
 353
 354 sendNotification STextDocumentDidChange params = do
 355     let n = NotificationMessage "2.0" STextDocumentDidChange params
 356     oldVFS <- vfs <$> get
 357     let (newVFS,_) = changeFromClientVFS oldVFS n
 358     modify (\s -> s { vfs = newVFS })
 359     sendMessage n
 360
 361 sendNotification method params =
 362   case splitClientMethod method of
 363     IsClientNot -> sendMessage (NotificationMessage "2.0" method params)
 364     IsClientEither -> sendMessage (NotMess $ NotificationMessage "2.0" method params)
 365
 366 -- | Sends a response to the server.
 367 sendResponse :: ToJSON (ResponseResult m) => ResponseMessage m -> Session ()
 368 sendResponse = sendMessage
 369
 370 -- | Returns the initialize response that was received from the server.
 371 -- The initialize requests and responses are not included the session,
 372 -- so if you need to test it use this.
 373 initializeResponse :: Session (ResponseMessage Initialize)
 374 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
 375
 376 -- | /Creates/ a new text document. This is different from 'openDoc'
 377 -- as it sends a workspace/didChangeWatchedFiles notification letting the server
 378 -- know that a file was created within the workspace, __provided that the server
 379 -- has registered for it__, and the file matches any patterns the server
 380 -- registered for.
 381 -- It /does not/ actually create a file on disk, but is useful for convincing
 382 -- the server that one does exist.
 383 --
 384 -- @since 11.0.0.0
 385 createDoc :: FilePath -- ^ The path to the document to open, __relative to the root directory__.
 386           -> String -- ^ The text document's language identifier, e.g. @"haskell"@.
 387           -> T.Text -- ^ The content of the text document to create.
 388           -> Session TextDocumentIdentifier -- ^ The identifier of the document just created.
 389 createDoc file languageId contents = do
 390   dynCaps <- curDynCaps <$> get
 391   rootDir <- asks rootDir
 392   caps <- asks sessionCapabilities
 393   absFile <- liftIO $ canonicalizePath (rootDir </> file)
 394   let pred :: SomeRegistration -> [Registration WorkspaceDidChangeWatchedFiles]
 395       pred (SomeRegistration r@(Registration _ SWorkspaceDidChangeWatchedFiles _)) = [r]
 396       pred _ = mempty
 397       regs = concatMap pred $ Map.elems dynCaps
 398       watchHits :: FileSystemWatcher -> Bool
 399       watchHits (FileSystemWatcher pattern kind) =
 400         -- If WatchKind is exlcuded, defaults to all true as per spec
 401         fileMatches pattern && createHits (fromMaybe (WatchKind True True True) kind)
 402
 403       fileMatches pattern = Glob.match (Glob.compile pattern) relOrAbs
 404         -- If the pattern is absolute then match against the absolute fp
 405         where relOrAbs
 406                 | isAbsolute pattern = absFile
 407                 | otherwise = file
 408
 409       createHits (WatchKind create _ _) = create
 410
 411       regHits :: Registration WorkspaceDidChangeWatchedFiles -> Bool
 412       regHits reg = foldl' (\acc w -> acc || watchHits w) False (reg ^. registerOptions . watchers)
 413
 414       clientCapsSupports =
 415           caps ^? workspace . _Just . didChangeWatchedFiles . _Just . dynamicRegistration . _Just
 416             == Just True
 417       shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs
 418
 419   when shouldSend $
 420     sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
 421       List [ FileEvent (filePathToUri (rootDir </> file)) FcCreated ]
 422   openDoc' file languageId contents
 423
 424 -- | Opens a text document that /exists on disk/, and sends a
 425 -- textDocument/didOpen notification to the server.
 426 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 427 openDoc file languageId = do
 428   context <- ask
 429   let fp = rootDir context </> file
 430   contents <- liftIO $ T.readFile fp
 431   openDoc' file languageId contents
 432
 433 -- | This is a variant of `openDoc` that takes the file content as an argument.
 434 -- Use this is the file exists /outside/ of the current workspace.
 435 openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
 436 openDoc' file languageId contents = do
 437   context <- ask
 438   let fp = rootDir context </> file
 439       uri = filePathToUri fp
 440       item = TextDocumentItem uri (T.pack languageId) 0 contents
 441   sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams item)
 442   pure $ TextDocumentIdentifier uri
 443
 444 -- | Closes a text document and sends a textDocument/didOpen notification to the server.
 445 closeDoc :: TextDocumentIdentifier -> Session ()
 446 closeDoc docId = do
 447   let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
 448   sendNotification STextDocumentDidClose params
 449
 450 -- | Changes a text document and sends a textDocument/didOpen notification to the server.
 451 changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()
 452 changeDoc docId changes = do
 453   verDoc <- getVersionedDoc docId
 454   let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes)
 455   sendNotification STextDocumentDidChange params
 456
 457 -- | Gets the Uri for the file corrected to the session directory.
 458 getDocUri :: FilePath -> Session Uri
 459 getDocUri file = do
 460   context <- ask
 461   let fp = rootDir context </> file
 462   return $ filePathToUri fp
 463
 464 -- | Waits for diagnostics to be published and returns them.
 465 waitForDiagnostics :: Session [Diagnostic]
 466 waitForDiagnostics = do
 467   diagsNot <- skipManyTill anyMessage (message STextDocumentPublishDiagnostics)
 468   let (List diags) = diagsNot ^. params . LSP.diagnostics
 469   return diags
 470
 471 -- | The same as 'waitForDiagnostics', but will only match a specific
 472 -- 'Language.LSP.Types._source'.
 473 waitForDiagnosticsSource :: String -> Session [Diagnostic]
 474 waitForDiagnosticsSource src = do
 475   diags <- waitForDiagnostics
 476   let res = filter matches diags
 477   if null res
 478     then waitForDiagnosticsSource src
 479     else return res
 480   where
 481     matches :: Diagnostic -> Bool
 482     matches d = d ^. source == Just (T.pack src)
 483
 484 -- | Expects a 'PublishDiagnosticsNotification' and throws an
 485 -- 'UnexpectedDiagnostics' exception if there are any diagnostics
 486 -- returned.
 487 noDiagnostics :: Session ()
 488 noDiagnostics = do
 489   diagsNot <- message STextDocumentPublishDiagnostics
 490   when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
 491
 492 -- | Returns the symbols in a document.
 493 getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
 494 getDocumentSymbols doc = do
 495   ResponseMessage _ rspLid res <- request STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc)
 496   case res of
 497     Right (InL (List xs)) -> return (Left xs)
 498     Right (InR (List xs)) -> return (Right xs)
 499     Left err -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) err)
 500
 501 -- | Returns the code actions in the specified range.
 502 getCodeActions :: TextDocumentIdentifier -> Range -> Session [Command |? CodeAction]
 503 getCodeActions doc range = do
 504   ctx <- getCodeActionContext doc
 505   rsp <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc range ctx)
 506
 507   case rsp ^. result of
 508     Right (List xs) -> return xs
 509     Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) error)
 510
 511 -- | Returns all the code actions in a document by
 512 -- querying the code actions at each of the current
 513 -- diagnostics' positions.
 514 getAllCodeActions :: TextDocumentIdentifier -> Session [Command |? CodeAction]
 515 getAllCodeActions doc = do
 516   ctx <- getCodeActionContext doc
 517
 518   foldM (go ctx) [] =<< getCurrentDiagnostics doc
 519
 520   where
 521     go :: CodeActionContext -> [Command |? CodeAction] -> Diagnostic -> Session [Command |? CodeAction]
 522     go ctx acc diag = do
 523       ResponseMessage _ rspLid res <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. range) ctx)
 524
 525       case res of
 526         Left e -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) e)
 527         Right (List cmdOrCAs) -> pure (acc ++ cmdOrCAs)
 528
 529 getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
 530 getCodeActionContext doc = do
 531   curDiags <- getCurrentDiagnostics doc
 532   return $ CodeActionContext (List curDiags) Nothing
 533
 534 -- | Returns the current diagnostics that have been sent to the client.
 535 -- Note that this does not wait for more to come in.
 536 getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
 537 getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. uri) . curDiagnostics <$> get
 538
 539 -- | Returns the tokens of all progress sessions that have started but not yet ended.
 540 getIncompleteProgressSessions :: Session (Set.Set ProgressToken)
 541 getIncompleteProgressSessions = curProgressSessions <$> get
 542
 543 -- | Executes a command.
 544 executeCommand :: Command -> Session ()
 545 executeCommand cmd = do
 546   let args = decode $ encode $ fromJust $ cmd ^. arguments
 547       execParams = ExecuteCommandParams Nothing (cmd ^. command) args
 548   void $ sendRequest SWorkspaceExecuteCommand execParams
 549
 550 -- | Executes a code action.
 551 -- Matching with the specification, if a code action
 552 -- contains both an edit and a command, the edit will
 553 -- be applied first.
 554 executeCodeAction :: CodeAction -> Session ()
 555 executeCodeAction action = do
 556   maybe (return ()) handleEdit $ action ^. edit
 557   maybe (return ()) executeCommand $ action ^. command
 558
 559   where handleEdit :: WorkspaceEdit -> Session ()
 560         handleEdit e =
 561           -- Its ok to pass in dummy parameters here as they aren't used
 562           let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing e)
 563             in updateState (FromServerMess SWorkspaceApplyEdit req)
 564
 565 -- | Adds the current version to the document, as tracked by the session.
 566 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
 567 getVersionedDoc (TextDocumentIdentifier uri) = do
 568   fs <- vfsMap . vfs <$> get
 569   let ver =
 570         case fs Map.!? toNormalizedUri uri of
 571           Just vf -> Just (virtualFileVersion vf)
 572           _ -> Nothing
 573   return (VersionedTextDocumentIdentifier uri ver)
 574
 575 -- | Applys an edit to the document and returns the updated document version.
 576 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
 577 applyEdit doc edit = do
 578
 579   verDoc <- getVersionedDoc doc
 580
 581   caps <- asks sessionCapabilities
 582
 583   let supportsDocChanges = fromMaybe False $ do
 584         let mWorkspace = caps ^. LSP.workspace
 585         C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
 586         C.WorkspaceEditClientCapabilities mDocChanges _ _ <- mEdit
 587         mDocChanges
 588
 589   let wEdit = if supportsDocChanges
 590       then
 591         let docEdit = TextDocumentEdit verDoc (List [edit])
 592         in WorkspaceEdit Nothing (Just (List [InL docEdit]))
 593       else
 594         let changes = HashMap.singleton (doc ^. uri) (List [edit])
 595         in WorkspaceEdit (Just changes) Nothing
 596
 597   let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)
 598   updateState (FromServerMess SWorkspaceApplyEdit req)
 599
 600   -- version may have changed
 601   getVersionedDoc doc
 602
 603 -- | Returns the completions for the position in the document.
 604 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
 605 getCompletions doc pos = do
 606   rsp <- request STextDocumentCompletion (CompletionParams doc pos Nothing Nothing Nothing)
 607
 608   case getResponseResult rsp of
 609     InL (List items) -> return items
 610     InR (CompletionList _ (List items)) -> return items
 611
 612 -- | Returns the references for the position in the document.
 613 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
 614               -> Position -- ^ The position to lookup.
 615               -> Bool -- ^ Whether to include declarations as references.
 616               -> Session (List Location) -- ^ The locations of the references.
 617 getReferences doc pos inclDecl =
 618   let ctx = ReferenceContext inclDecl
 619       params = ReferenceParams doc pos Nothing Nothing ctx
 620   in getResponseResult <$> request STextDocumentReferences params
 621
 622 -- | Returns the declarations(s) for the term at the specified position.
 623 getDeclarations :: TextDocumentIdentifier -- ^ The document the term is in.
 624                 -> Position -- ^ The position the term is at.
 625                 -> Session ([Location] |? [LocationLink])
 626 getDeclarations = getDeclarationyRequest STextDocumentDeclaration DeclarationParams
 627
 628 -- | Returns the definition(s) for the term at the specified position.
 629 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
 630                -> Position -- ^ The position the term is at.
 631                -> Session ([Location] |? [LocationLink])
 632 getDefinitions = getDeclarationyRequest STextDocumentDefinition DefinitionParams
 633
 634 -- | Returns the type definition(s) for the term at the specified position.
 635 getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
 636                    -> Position -- ^ The position the term is at.
 637                    -> Session ([Location] |? [LocationLink])
 638 getTypeDefinitions = getDeclarationyRequest STextDocumentTypeDefinition TypeDefinitionParams
 639
 640 -- | Returns the type definition(s) for the term at the specified position.
 641 getImplementations :: TextDocumentIdentifier -- ^ The document the term is in.
 642                    -> Position -- ^ The position the term is at.
 643                    -> Session ([Location] |? [LocationLink])
 644 getImplementations = getDeclarationyRequest STextDocumentImplementation ImplementationParams
 645
 646
 647 getDeclarationyRequest :: (ResponseResult m ~ (Location |? (List Location |? List LocationLink)))
 648                        => SClientMethod m
 649                        -> (TextDocumentIdentifier
 650                             -> Position
 651                             -> Maybe ProgressToken
 652                             -> Maybe ProgressToken
 653                             -> MessageParams m)
 654                        -> TextDocumentIdentifier
 655                        -> Position
 656                        -> Session ([Location] |? [LocationLink])
 657 getDeclarationyRequest method paramCons doc pos = do
 658   let params = paramCons doc pos Nothing Nothing
 659   rsp <- request method params
 660   case getResponseResult rsp of
 661       InL loc -> pure (InL [loc])
 662       InR (InL (List locs)) -> pure (InL locs)
 663       InR (InR (List locLinks)) -> pure (InR locLinks)
 664
 665 -- | Renames the term at the specified position.
 666 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
 667 rename doc pos newName = do
 668   let params = RenameParams doc pos Nothing (T.pack newName)
 669   rsp <- request STextDocumentRename params
 670   let wEdit = getResponseResult rsp
 671       req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)
 672   updateState (FromServerMess SWorkspaceApplyEdit req)
 673
 674 -- | Returns the hover information at the specified position.
 675 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
 676 getHover doc pos =
 677   let params = HoverParams doc pos Nothing
 678   in getResponseResult <$> request STextDocumentHover params
 679
 680 -- | Returns the highlighted occurences of the term at the specified position
 681 getHighlights :: TextDocumentIdentifier -> Position -> Session (List DocumentHighlight)
 682 getHighlights doc pos =
 683   let params = DocumentHighlightParams doc pos Nothing Nothing
 684   in getResponseResult <$> request STextDocumentDocumentHighlight params
 685
 686 -- | Checks the response for errors and throws an exception if needed.
 687 -- Returns the result if successful.
 688 getResponseResult :: ResponseMessage m -> ResponseResult m
 689 getResponseResult rsp =
 690   case rsp ^. result of
 691     Right x -> x
 692     Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) err
 693
 694 -- | Applies formatting to the specified document.
 695 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
 696 formatDoc doc opts = do
 697   let params = DocumentFormattingParams Nothing doc opts
 698   edits <- getResponseResult <$> request STextDocumentFormatting params
 699   applyTextEdits doc edits
 700
 701 -- | Applies formatting to the specified range in a document.
 702 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
 703 formatRange doc opts range = do
 704   let params = DocumentRangeFormattingParams Nothing doc range opts
 705   edits <- getResponseResult <$> request STextDocumentRangeFormatting params
 706   applyTextEdits doc edits
 707
 708 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
 709 applyTextEdits doc edits =
 710   let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
 711       -- Send a dummy message to updateState so it can do bookkeeping
 712       req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)
 713   in updateState (FromServerMess SWorkspaceApplyEdit req)
 714
 715 -- | Returns the code lenses for the specified document.
 716 getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens]
 717 getCodeLenses tId = do
 718     rsp <- request STextDocumentCodeLens (CodeLensParams Nothing Nothing tId)
 719     case getResponseResult rsp of
 720         List res -> pure res
 721
 722 -- | Returns a list of capabilities that the server has requested to /dynamically/
 723 -- register during the 'Session'.
 724 --
 725 -- @since 0.11.0.0
 726 getRegisteredCapabilities :: Session [SomeRegistration]
 727 getRegisteredCapabilities = (Map.elems . curDynCaps) <$> get