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