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