src/Language/Haskell/LSP/Test.hs

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