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