src/Language/LSP/Test.hs

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