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