src/Language/Haskell/LSP/Test.hs

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