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