src/Language/Haskell/LSP/Test.hs

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