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