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