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