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