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