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