src/Language/Haskell/LSP/Test.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE RankNTypes #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 {-# LANGUAGE ExistentialQuantification #-}
   5
   6 {-|
   7 Module      : Language.Haskell.LSP.Test
   8 Description : A functional testing framework for LSP servers.
   9 Maintainer  : luke_lau@icloud.com
  10 Stability   : experimental
  11 Portability : POSIX
  12
  13 Provides the framework to start functionally testing
  14 <https://github.com/Microsoft/language-server-protocol Language Server Protocol servers>.
  15 You should import "Language.Haskell.LSP.Types" alongside this.
  16 -}
  17 module Language.Haskell.LSP.Test
  18   (
  19   -- * Sessions
  20     Session
  21   , runSession
  22   -- ** Config
  23   , runSessionWithConfig
  24   , SessionConfig(..)
  25   , defaultConfig
  26   , C.fullCaps
  27   -- ** Exceptions
  28   , module Language.Haskell.LSP.Test.Exceptions
  29   , withTimeout
  30   -- * Sending
  31   , request
  32   , request_
  33   , sendRequest
  34   , sendNotification
  35   , sendResponse
  36   -- * Receving
  37   , module Language.Haskell.LSP.Test.Parsing
  38   -- * Utilities
  39   -- | Quick helper functions for common tasks.
  40   -- ** Initialization
  41   , initializeResponse
  42   -- ** Documents
  43   , openDoc
  44   , closeDoc
  45   , documentContents
  46   , getDocumentEdit
  47   , getDocUri
  48   , getVersionedDoc
  49   -- ** Symbols
  50   , getDocumentSymbols
  51   -- ** Diagnostics
  52   , waitForDiagnostics
  53   , waitForDiagnosticsSource
  54   , noDiagnostics
  55   , getCurrentDiagnostics
  56   -- ** Commands
  57   , executeCommand
  58   -- ** Code Actions
  59   , getCodeActions
  60   , getAllCodeActions
  61   , executeCodeAction
  62   -- ** Completions
  63   , getCompletions
  64   -- ** References
  65   , getReferences
  66   -- ** Definitions
  67   , getDefinitions
  68   -- ** Renaming
  69   , rename
  70   -- ** Hover
  71   , getHover
  72   -- ** Highlights
  73   , getHighlights
  74   -- ** Formatting
  75   , formatDoc
  76   , formatRange
  77   -- ** Edits
  78   , applyEdit
  79   ) where
  80
  81 import Control.Applicative.Combinators
  82 import Control.Concurrent
  83 import Control.Monad
  84 import Control.Monad.IO.Class
  85 import Control.Exception
  86 import Control.Lens hiding ((.=), List)
  87 import qualified Data.Text as T
  88 import qualified Data.Text.IO as T
  89 import Data.Aeson
  90 import Data.Default
  91 import qualified Data.HashMap.Strict as HashMap
  92 import qualified Data.Map as Map
  93 import Data.Maybe
  94 import Language.Haskell.LSP.Types
  95 import Language.Haskell.LSP.Types.Lens hiding
  96   (id, capabilities, message, executeCommand, applyEdit, rename)
  97 import qualified Language.Haskell.LSP.Types.Lens as LSP
  98 import qualified Language.Haskell.LSP.Types.Capabilities as C
  99 import Language.Haskell.LSP.Messages
 100 import Language.Haskell.LSP.VFS
 101 import Language.Haskell.LSP.Test.Compat
 102 import Language.Haskell.LSP.Test.Decoding
 103 import Language.Haskell.LSP.Test.Exceptions
 104 import Language.Haskell.LSP.Test.Parsing
 105 import Language.Haskell.LSP.Test.Session
 106 import Language.Haskell.LSP.Test.Server
 107 import System.IO
 108 import System.Directory
 109 import System.FilePath
 110 import qualified Yi.Rope as Rope
 111
 112 -- | Starts a new session.
 113 --
 114 -- > runSession "hie" fullCaps "path/to/root/dir" $ do
 115 -- >   doc <- openDoc "Desktop/simple.hs" "haskell"
 116 -- >   diags <- waitForDiagnostics
 117 -- >   let pos = Position 12 5
 118 -- >       params = TextDocumentPositionParams doc
 119 -- >   hover <- request TextDocumentHover params
 120 runSession :: String -- ^ The command to run the server.
 121            -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
 122            -> FilePath -- ^ The filepath to the root directory for the session.
 123            -> Session a -- ^ The session to run.
 124            -> IO a
 125 runSession = runSessionWithConfig def
 126
 127 -- | Starts a new sesion with a custom configuration.
 128 runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session.
 129                      -> String -- ^ The command to run the server.
 130                      -> C.ClientCapabilities -- ^ The capabilities that the client should declare.
 131                      -> FilePath -- ^ The filepath to the root directory for the session.
 132                      -> Session a -- ^ The session to run.
 133                      -> IO a
 134 runSessionWithConfig config serverExe caps rootDir session = do
 135   pid <- getCurrentProcessID
 136   absRootDir <- canonicalizePath rootDir
 137
 138   let initializeParams = InitializeParams (Just pid)
 139                                           (Just $ T.pack absRootDir)
 140                                           (Just $ filePathToUri absRootDir)
 141                                           Nothing
 142                                           caps
 143                                           (Just TraceOff)
 144                                           Nothing
 145   withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
 146     runSessionWithHandles serverIn serverOut listenServer config caps rootDir $ do
 147
 148       -- Wrap the session around initialize and shutdown calls
 149       initRspMsg <- request Initialize initializeParams :: Session InitializeResponse
 150
 151       liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
 152
 153       initRspVar <- initRsp <$> ask
 154       liftIO $ putMVar initRspVar initRspMsg
 155
 156       sendNotification Initialized InitializedParams
 157
 158       -- Run the actual test
 159       result <- session
 160
 161       sendNotification Exit ExitParams
 162
 163       return result
 164   where
 165   -- | Listens to the server output, makes sure it matches the record and
 166   -- signals any semaphores
 167   listenServer :: Handle -> SessionContext -> IO ()
 168   listenServer serverOut context = do
 169     msgBytes <- getNextMessage serverOut
 170
 171     reqMap <- readMVar $ requestMap context
 172
 173     let msg = decodeFromServerMsg reqMap msgBytes
 174     writeChan (messageChan context) (ServerMessage msg)
 175
 176     listenServer serverOut context
 177
 178 -- | The current text contents of a document.
 179 documentContents :: TextDocumentIdentifier -> Session T.Text
 180 documentContents doc = do
 181   vfs <- vfs <$> get
 182   let file = vfs Map.! (doc ^. uri)
 183   return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
 184
 185 -- | Parses an ApplyEditRequest, checks that it is for the passed document
 186 -- and returns the new content
 187 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
 188 getDocumentEdit doc = do
 189   req <- message :: Session ApplyWorkspaceEditRequest
 190
 191   unless (checkDocumentChanges req || checkChanges req) $
 192     liftIO $ throw (IncorrectApplyEditRequest (show req))
 193
 194   documentContents doc
 195   where
 196     checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
 197     checkDocumentChanges req =
 198       let changes = req ^. params . edit . documentChanges
 199           maybeDocs = fmap (fmap (^. textDocument . uri)) changes
 200       in case maybeDocs of
 201         Just docs -> (doc ^. uri) `elem` docs
 202         Nothing -> False
 203     checkChanges :: ApplyWorkspaceEditRequest -> Bool
 204     checkChanges req =
 205       let mMap = req ^. params . edit . changes
 206         in maybe False (HashMap.member (doc ^. uri)) mMap
 207
 208 -- | Sends a request to the server and waits for its response.
 209 -- Will skip any messages in between the request and the response
 210 -- @
 211 -- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
 212 -- @
 213 -- Note: will skip any messages in between the request and the response.
 214 request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
 215 request m = sendRequest m >=> skipManyTill anyMessage . responseForId
 216
 217 -- | The same as 'sendRequest', but discard the response.
 218 request_ :: ToJSON params => ClientMethod -> params -> Session ()
 219 request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
 220
 221 -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
 222 sendRequest
 223   :: ToJSON params
 224   => ClientMethod -- ^ The request method.
 225   -> params -- ^ The request parameters.
 226   -> Session LspId -- ^ The id of the request that was sent.
 227 sendRequest method params = do
 228   id <- curReqId <$> get
 229   modify $ \c -> c { curReqId = nextId id }
 230
 231   let req = RequestMessage' "2.0" id method params
 232
 233   -- Update the request map
 234   reqMap <- requestMap <$> ask
 235   liftIO $ modifyMVar_ reqMap $
 236     \r -> return $ updateRequestMap r id method
 237
 238   sendMessage req
 239
 240   return id
 241
 242   where nextId (IdInt i) = IdInt (i + 1)
 243         nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
 244
 245 -- | A custom type for request message that doesn't
 246 -- need a response type, allows us to infer the request
 247 -- message type without using proxies.
 248 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
 249
 250 instance ToJSON a => ToJSON (RequestMessage' a) where
 251   toJSON (RequestMessage' rpc id method params) =
 252     object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
 253
 254
 255 -- | Sends a notification to the server.
 256 sendNotification :: ToJSON a
 257                  => ClientMethod -- ^ The notification method.
 258                  -> a -- ^ The notification parameters.
 259                  -> Session ()
 260
 261 -- Open a virtual file if we send a did open text document notification
 262 sendNotification TextDocumentDidOpen params = do
 263   let params' = fromJust $ decode $ encode params
 264       n :: DidOpenTextDocumentNotification
 265       n = NotificationMessage "2.0" TextDocumentDidOpen params'
 266   oldVFS <- vfs <$> get
 267   newVFS <- liftIO $ openVFS oldVFS n
 268   modify (\s -> s { vfs = newVFS })
 269   sendMessage n
 270
 271 -- Close a virtual file if we send a close text document notification
 272 sendNotification TextDocumentDidClose params = do
 273   let params' = fromJust $ decode $ encode params
 274       n :: DidCloseTextDocumentNotification
 275       n = NotificationMessage "2.0" TextDocumentDidClose params'
 276   oldVFS <- vfs <$> get
 277   newVFS <- liftIO $ closeVFS oldVFS n
 278   modify (\s -> s { vfs = newVFS })
 279   sendMessage n
 280
 281 sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
 282
 283 -- | Sends a response to the server.
 284 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
 285 sendResponse = sendMessage
 286
 287 -- | Returns the initialize response that was received from the server.
 288 -- The initialize requests and responses are not included the session,
 289 -- so if you need to test it use this.
 290 initializeResponse :: Session InitializeResponse
 291 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
 292
 293 -- | Opens a text document and sends a notification to the client.
 294 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 295 openDoc file languageId = do
 296   item <- getDocItem file languageId
 297   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
 298   TextDocumentIdentifier <$> getDocUri file
 299   where
 300   -- | Reads in a text document as the first version.
 301   getDocItem :: FilePath -- ^ The path to the text document to read in.
 302             -> String -- ^ The language ID, e.g "haskell" for .hs files.
 303             -> Session TextDocumentItem
 304   getDocItem file languageId = do
 305     context <- ask
 306     let fp = rootDir context </> file
 307     contents <- liftIO $ T.readFile fp
 308     return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
 309
 310 -- | Closes a text document and sends a notification to the client.
 311 closeDoc :: TextDocumentIdentifier -> Session ()
 312 closeDoc docId = do
 313   let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
 314   sendNotification TextDocumentDidClose params
 315
 316   oldVfs <- vfs <$> get
 317   let notif = NotificationMessage "" TextDocumentDidClose params
 318   newVfs <- liftIO $ closeVFS oldVfs notif
 319   modify $ \s -> s { vfs = newVfs }
 320
 321 -- | Gets the Uri for the file corrected to the session directory.
 322 getDocUri :: FilePath -> Session Uri
 323 getDocUri file = do
 324   context <- ask
 325   let fp = rootDir context </> file
 326   return $ filePathToUri fp
 327
 328 -- | Waits for diagnostics to be published and returns them.
 329 waitForDiagnostics :: Session [Diagnostic]
 330 waitForDiagnostics = do
 331   diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
 332   let (List diags) = diagsNot ^. params . LSP.diagnostics
 333   return diags
 334
 335 -- | The same as 'waitForDiagnostics', but will only match a specific
 336 -- 'Language.Haskell.LSP.Types._source'.
 337 waitForDiagnosticsSource :: String -> Session [Diagnostic]
 338 waitForDiagnosticsSource src = do
 339   diags <- waitForDiagnostics
 340   let res = filter matches diags
 341   if null res
 342     then waitForDiagnosticsSource src
 343     else return res
 344   where
 345     matches :: Diagnostic -> Bool
 346     matches d = d ^. source == Just (T.pack src)
 347
 348 -- | Expects a 'PublishDiagnosticsNotification' and throws an
 349 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
 350 -- returned.
 351 noDiagnostics :: Session ()
 352 noDiagnostics = do
 353   diagsNot <- message :: Session PublishDiagnosticsNotification
 354   when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
 355
 356 -- | Returns the symbols in a document.
 357 getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
 358 getDocumentSymbols doc = do
 359   ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc) :: Session DocumentSymbolsResponse
 360   maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
 361   case mRes of
 362     Just (DSDocumentSymbols (List xs)) -> return (Left xs)
 363     Just (DSSymbolInformation (List xs)) -> return (Right xs)
 364     Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse"
 365
 366 -- | Returns the code actions in the specified range.
 367 getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
 368 getCodeActions doc range = do
 369   ctx <- getCodeActionContext doc
 370   rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx)
 371
 372   case rsp ^. result of
 373     Just (List xs) -> return xs
 374     _ -> throw (UnexpectedResponseError (rsp ^. LSP.id) (fromJust $ rsp ^. LSP.error))
 375
 376 -- | Returns all the code actions in a document by
 377 -- querying the code actions at each of the current
 378 -- diagnostics' positions.
 379 getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
 380 getAllCodeActions doc = do
 381   ctx <- getCodeActionContext doc
 382
 383   foldM (go ctx) [] =<< getCurrentDiagnostics doc
 384
 385   where
 386     go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
 387     go ctx acc diag = do
 388       ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
 389
 390       case mErr of
 391         Just e -> throw (UnexpectedResponseError rspLid e)
 392         Nothing ->
 393           let Just (List cmdOrCAs) = mRes
 394             in return (acc ++ cmdOrCAs)
 395
 396 getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
 397 getCodeActionContext doc = do
 398   curDiags <- getCurrentDiagnostics doc
 399   return $ CodeActionContext (List curDiags) Nothing
 400
 401 -- | Returns the current diagnostics that have been sent to the client.
 402 -- Note that this does not wait for more to come in.
 403 getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]
 404 getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
 405
 406 -- | Executes a command.
 407 executeCommand :: Command -> Session ()
 408 executeCommand cmd = do
 409   let args = decode $ encode $ fromJust $ cmd ^. arguments
 410       execParams = ExecuteCommandParams (cmd ^. command) args
 411   request_ WorkspaceExecuteCommand execParams
 412
 413 -- | Executes a code action.
 414 -- Matching with the specification, if a code action
 415 -- contains both an edit and a command, the edit will
 416 -- be applied first.
 417 executeCodeAction :: CodeAction -> Session ()
 418 executeCodeAction action = do
 419   maybe (return ()) handleEdit $ action ^. edit
 420   maybe (return ()) executeCommand $ action ^. command
 421
 422   where handleEdit :: WorkspaceEdit -> Session ()
 423         handleEdit e =
 424           -- Its ok to pass in dummy parameters here as they aren't used
 425           let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
 426             in updateState (ReqApplyWorkspaceEdit req)
 427
 428 -- | Adds the current version to the document, as tracked by the session.
 429 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
 430 getVersionedDoc (TextDocumentIdentifier uri) = do
 431   fs <- vfs <$> get
 432   let ver =
 433         case fs Map.!? uri of
 434           Just (VirtualFile v _) -> Just v
 435           _ -> Nothing
 436   return (VersionedTextDocumentIdentifier uri ver)
 437
 438 -- | Applys an edit to the document and returns the updated document version.
 439 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
 440 applyEdit doc edit = do
 441
 442   verDoc <- getVersionedDoc doc
 443
 444   caps <- asks sessionCapabilities
 445
 446   let supportsDocChanges = fromMaybe False $ do
 447         let C.ClientCapabilities mWorkspace _ _ = caps
 448         C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
 449         C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
 450         mDocChanges
 451
 452   let wEdit = if supportsDocChanges
 453       then
 454         let docEdit = TextDocumentEdit verDoc (List [edit])
 455         in WorkspaceEdit Nothing (Just (List [docEdit]))
 456       else
 457         let changes = HashMap.singleton (doc ^. uri) (List [edit])
 458         in WorkspaceEdit (Just changes) Nothing
 459
 460   let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
 461   updateState (ReqApplyWorkspaceEdit req)
 462
 463   -- version may have changed
 464   getVersionedDoc doc
 465
 466 -- | Returns the completions for the position in the document.
 467 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
 468 getCompletions doc pos = do
 469   rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos)
 470
 471   case getResponseResult rsp of
 472     Completions (List items) -> return items
 473     CompletionList (CompletionListType _ (List items)) -> return items
 474
 475 -- | Returns the references for the position in the document.
 476 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
 477               -> Position -- ^ The position to lookup.
 478               -> Bool -- ^ Whether to include declarations as references.
 479               -> Session [Location] -- ^ The locations of the references.
 480 getReferences doc pos inclDecl =
 481   let ctx = ReferenceContext inclDecl
 482       params = ReferenceParams doc pos ctx
 483   in getResponseResult <$> request TextDocumentReferences params
 484
 485 -- | Returns the definition(s) for the term at the specified position.
 486 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
 487                -> Position -- ^ The position the term is at.
 488                -> Session [Location] -- ^ The location(s) of the definitions
 489 getDefinitions doc pos =
 490   let params = TextDocumentPositionParams doc pos
 491   in getResponseResult <$> request TextDocumentDefinition params
 492
 493 -- | Renames the term at the specified position.
 494 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
 495 rename doc pos newName = do
 496   let params = RenameParams doc pos (T.pack newName)
 497   rsp <- request TextDocumentRename params :: Session RenameResponse
 498   let wEdit = getResponseResult rsp
 499       req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
 500   updateState (ReqApplyWorkspaceEdit req)
 501
 502 -- | Returns the hover information at the specified position.
 503 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
 504 getHover doc pos =
 505   let params = TextDocumentPositionParams doc pos
 506   in getResponseResult <$> request TextDocumentHover params
 507
 508 -- | Returns the highlighted occurences of the term at the specified position
 509 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
 510 getHighlights doc pos =
 511   let params = TextDocumentPositionParams doc pos
 512   in getResponseResult <$> request TextDocumentDocumentHighlight params
 513
 514 -- | Checks the response for errors and throws an exception if needed.
 515 -- Returns the result if successful.
 516 getResponseResult :: ResponseMessage a -> a
 517 getResponseResult rsp = fromMaybe exc (rsp ^. result)
 518   where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
 519                                               (fromJust $ rsp ^. LSP.error)
 520
 521 -- | Applies formatting to the specified document.
 522 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
 523 formatDoc doc opts = do
 524   let params = DocumentFormattingParams doc opts
 525   edits <- getResponseResult <$> request TextDocumentFormatting params
 526   applyTextEdits doc edits
 527
 528 -- | Applies formatting to the specified range in a document.
 529 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
 530 formatRange doc opts range = do
 531   let params = DocumentRangeFormattingParams doc range opts
 532   edits <- getResponseResult <$> request TextDocumentRangeFormatting params
 533   applyTextEdits doc edits
 534
 535 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
 536 applyTextEdits doc edits =
 537   let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
 538       req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
 539   in updateState (ReqApplyWorkspaceEdit req)