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   , SessionT
  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   , getOpenDocs
  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 Conduit (MonadThrow)
  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 :: (MonadIO m, MonadThrow m)
 120            => String -- ^ The command to run the server.
 121            -> LSP.ClientCapabilities -- ^ The capabilities that the client should declare.
 122            -> FilePath -- ^ The filepath to the root directory for the session.
 123            -> SessionT m a -- ^ The session to run.
 124            -> m a
 125 runSession = runSessionWithConfig def
 126
 127 -- | Starts a new sesion with a client with the specified capabilities.
 128 runSessionWithConfig :: forall m a. (MonadIO m, MonadThrow m)
 129                      => SessionConfig -- ^ Configuration options for the session.
 130                      -> String -- ^ The command to run the server.
 131                      -> LSP.ClientCapabilities -- ^ The capabilities that the client should declare.
 132                      -> FilePath -- ^ The filepath to the root directory for the session.
 133                      -> SessionT m a -- ^ The session to run.
 134                      -> m a
 135 runSessionWithConfig config serverExe caps rootDir session = do
 136   pid <- liftIO getCurrentProcessID
 137   absRootDir <- liftIO $ canonicalizePath rootDir
 138
 139   let initializeParams = InitializeParams (Just pid)
 140                                           (Just $ T.pack absRootDir)
 141                                           (Just $ filePathToUri absRootDir)
 142                                           Nothing
 143                                           caps
 144                                           (Just TraceOff)
 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 <- sendRequest Initialize initializeParams :: SessionT m 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 :: MonadIO m => TextDocumentIdentifier -> SessionT m 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 :: forall m. MonadIO m => TextDocumentIdentifier -> SessionT m T.Text
 188 getDocumentEdit doc = do
 189   req <- message :: SessionT m 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 -- @
 210 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: SessionT m DocumentSymbolsResponse
 211 -- @
 212 -- Note: will skip any messages in between the request and the response.
 213 sendRequest :: (MonadIO m, ToJSON params, FromJSON a) => ClientMethod -> params -> SessionT m (ResponseMessage a)
 214 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
 215
 216 -- | Send a request to the server and wait for its response,
 217 -- but discard it.
 218 sendRequest_ :: forall m params. (MonadIO m, ToJSON params) => ClientMethod -> params -> SessionT m ()
 219 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> SessionT m (ResponseMessage Value))
 220
 221 -- | Sends a request to the server without waiting on the response.
 222 sendRequest'
 223   :: (ToJSON params, MonadIO m)
 224   => ClientMethod -- ^ The request method.
 225   -> params -- ^ The request parameters.
 226   -> SessionT m 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 sendRequestMessage :: (MonadIO m, ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> SessionT m ()
 256 sendRequestMessage req = do
 257   -- Update the request map
 258   reqMap <- requestMap <$> ask
 259   liftIO $ modifyMVar_ reqMap $
 260     \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
 261
 262   sendMessage req
 263
 264 -- | Sends a notification to the server.
 265 sendNotification :: (MonadIO m, ToJSON a)
 266                  => ClientMethod -- ^ The notification method.
 267                  -> a -- ^ The notification parameters.
 268                  -> SessionT m ()
 269
 270 -- | Open a virtual file if we send a did open text document notification
 271 sendNotification TextDocumentDidOpen params = do
 272   let params' = fromJust $ decode $ encode params
 273       n :: DidOpenTextDocumentNotification
 274       n = NotificationMessage "2.0" TextDocumentDidOpen params'
 275   oldVFS <- vfs <$> get
 276   newVFS <- liftIO $ openVFS oldVFS n
 277   modify (\s -> s { vfs = newVFS })
 278   sendNotification' n
 279
 280 -- | Close a virtual file if we send a close text document notification
 281 sendNotification TextDocumentDidClose params = do
 282   let params' = fromJust $ decode $ encode params
 283       n :: DidCloseTextDocumentNotification
 284       n = NotificationMessage "2.0" TextDocumentDidClose params'
 285   oldVFS <- vfs <$> get
 286   newVFS <- liftIO $ closeVFS oldVFS n
 287   modify (\s -> s { vfs = newVFS })
 288   sendNotification' n
 289
 290 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
 291
 292 sendNotification' :: (MonadIO m, ToJSON a, ToJSON b) => NotificationMessage a b -> SessionT m ()
 293 sendNotification' = sendMessage
 294
 295 sendResponse :: (MonadIO m, ToJSON a) => ResponseMessage a -> SessionT m ()
 296 sendResponse = sendMessage
 297
 298 -- | Returns the initialize response that was received from the server.
 299 -- The initialize requests and responses are not included the session,
 300 -- so if you need to test it use this.
 301 initializeResponse :: MonadIO m => SessionT m InitializeResponse
 302 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
 303
 304 -- | Opens a text document and sends a notification to the client.
 305 openDoc :: MonadIO m => FilePath -> String -> SessionT m TextDocumentIdentifier
 306 openDoc file languageId = do
 307   item <- getDocItem file languageId
 308   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
 309   TextDocumentIdentifier <$> getDocUri file
 310   where
 311   -- | Reads in a text document as the first version.
 312   getDocItem :: MonadIO m
 313              =>FilePath -- ^ The path to the text document to read in.
 314              -> String -- ^ The language ID, e.g "haskell" for .hs files.
 315              -> SessionT m TextDocumentItem
 316   getDocItem file languageId = do
 317     context <- ask
 318     let fp = rootDir context </> file
 319     contents <- liftIO $ T.readFile fp
 320     return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
 321
 322 -- | Closes a text document and sends a notification to the client.
 323 closeDoc :: MonadIO m => TextDocumentIdentifier -> SessionT m ()
 324 closeDoc docId = do
 325   let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
 326   sendNotification TextDocumentDidClose params
 327
 328   oldVfs <- vfs <$> get
 329   let notif = NotificationMessage "" TextDocumentDidClose params
 330   newVfs <- liftIO $ closeVFS oldVfs notif
 331   modify $ \s -> s { vfs = newVfs }
 332
 333 getOpenDocs :: MonadIO m => SessionT m [TextDocumentIdentifier]
 334 getOpenDocs = map TextDocumentIdentifier . Map.keys . vfs <$> get
 335
 336 -- | Gets the Uri for the file corrected to the session directory.
 337 getDocUri :: MonadIO m => FilePath -> SessionT m Uri
 338 getDocUri file = do
 339   context <- ask
 340   let fp = rootDir context </> file
 341   return $ filePathToUri fp
 342
 343 -- | Waits for diagnostics to be published and returns them.
 344 waitForDiagnostics :: forall m. MonadIO m => SessionT m [Diagnostic]
 345 waitForDiagnostics = do
 346   diagsNot <- skipManyTill anyMessage message :: SessionT m PublishDiagnosticsNotification
 347   let (List diags) = diagsNot ^. params . LSP.diagnostics
 348   return diags
 349
 350 waitForDiagnosticsSource :: MonadIO m => String -> SessionT m [Diagnostic]
 351 waitForDiagnosticsSource src = do
 352   diags <- waitForDiagnostics
 353   let res = filter matches diags
 354   if null res
 355     then waitForDiagnosticsSource src
 356     else return res
 357   where
 358     matches :: Diagnostic -> Bool
 359     matches d = d ^. source == Just (T.pack src)
 360
 361 -- | Expects a 'PublishDiagnosticsNotification' and throws an
 362 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
 363 -- returned.
 364 noDiagnostics :: forall m. MonadIO m => SessionT m ()
 365 noDiagnostics = do
 366   diagsNot <- message :: SessionT m PublishDiagnosticsNotification
 367   when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
 368
 369 -- | Returns the symbols in a document.
 370 getDocumentSymbols :: MonadIO m => TextDocumentIdentifier -> SessionT m [SymbolInformation]
 371 getDocumentSymbols doc = do
 372   ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
 373   maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
 374   let (Just (List symbols)) = mRes
 375   return symbols
 376
 377 -- | Returns all the code actions in a document by
 378 -- querying the code actions at each of the current
 379 -- diagnostics' positions.
 380 getAllCodeActions :: forall m. MonadIO m => TextDocumentIdentifier -> SessionT m [CommandOrCodeAction]
 381 getAllCodeActions doc = do
 382   curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
 383   let ctx = CodeActionContext (List curDiags) Nothing
 384
 385   foldM (go ctx) [] curDiags
 386
 387   where
 388     go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> SessionT m [CommandOrCodeAction]
 389     go ctx acc diag = do
 390       ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
 391
 392       case mErr of
 393         Just e -> throw (UnexpectedResponseError rspLid e)
 394         Nothing ->
 395           let Just (List cmdOrCAs) = mRes
 396             in return (acc ++ cmdOrCAs)
 397
 398 -- | Executes a command.
 399 executeCommand :: MonadIO m => Command -> SessionT m ()
 400 executeCommand cmd = do
 401   let args = decode $ encode $ fromJust $ cmd ^. arguments
 402       execParams = ExecuteCommandParams (cmd ^. command) args
 403   sendRequest_ WorkspaceExecuteCommand execParams
 404
 405 -- | Executes a code action.
 406 -- Matching with the specification, if a code action
 407 -- contains both an edit and a command, the edit will
 408 -- be applied first.
 409 executeCodeAction :: forall m. MonadIO m => CodeAction -> SessionT m ()
 410 executeCodeAction action = do
 411   maybe (return ()) handleEdit $ action ^. edit
 412   maybe (return ()) executeCommand $ action ^. command
 413
 414   where handleEdit :: WorkspaceEdit -> SessionT m ()
 415         handleEdit e =
 416           -- Its ok to pass in dummy parameters here as they aren't used
 417           let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
 418             in updateState (ReqApplyWorkspaceEdit req)
 419
 420 -- | Adds the current version to the document, as tracked by the session.
 421 getVersionedDoc :: MonadIO m => TextDocumentIdentifier -> SessionT m VersionedTextDocumentIdentifier
 422 getVersionedDoc (TextDocumentIdentifier uri) = do
 423   fs <- vfs <$> get
 424   let ver =
 425         case fs Map.!? uri of
 426           Just (VirtualFile v _) -> Just v
 427           _ -> Nothing
 428   return (VersionedTextDocumentIdentifier uri ver)
 429
 430 -- | Applys an edit to the document and returns the updated document version.
 431 applyEdit :: MonadIO m => TextDocumentIdentifier -> TextEdit -> SessionT m VersionedTextDocumentIdentifier
 432 applyEdit doc edit = do
 433
 434   verDoc <- getVersionedDoc doc
 435
 436   caps <- asks sessionCapabilities
 437
 438   let supportsDocChanges = fromMaybe False $ do
 439         let LSP.ClientCapabilities mWorkspace _ _ = caps
 440         LSP.WorkspaceClientCapabilities _ mEdit _ _ _ _ <- mWorkspace
 441         LSP.WorkspaceEditClientCapabilities mDocChanges <- mEdit
 442         mDocChanges
 443
 444   let wEdit = if supportsDocChanges
 445       then
 446         let docEdit = TextDocumentEdit verDoc (List [edit])
 447         in WorkspaceEdit Nothing (Just (List [docEdit]))
 448       else
 449         let changes = HashMap.singleton (doc ^. uri) (List [edit])
 450         in WorkspaceEdit (Just changes) Nothing
 451
 452   let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
 453   updateState (ReqApplyWorkspaceEdit req)
 454
 455   -- version may have changed
 456   getVersionedDoc doc
 457
 458 -- | Returns the completions for the position in the document.
 459 getCompletions :: MonadIO m => TextDocumentIdentifier -> Position -> SessionT m [CompletionItem]
 460 getCompletions doc pos = do
 461   rsp <- sendRequest TextDocumentCompletion (TextDocumentPositionParams doc pos)
 462
 463   case getResponseResult rsp of
 464     Completions (List items) -> return items
 465     CompletionList (CompletionListType _ (List items)) -> return items
 466
 467 -- | Returns the references for the position in the document.
 468 getReferences :: MonadIO m
 469               => TextDocumentIdentifier -- ^ The document to lookup in.
 470               -> Position -- ^ The position to lookup.
 471               -> Bool -- ^ Whether to include declarations as references.
 472               -> SessionT m [Location] -- ^ The locations of the references.
 473 getReferences doc pos inclDecl =
 474   let ctx = ReferenceContext inclDecl
 475       params = ReferenceParams doc pos ctx
 476   in getResponseResult <$> sendRequest TextDocumentReferences params
 477
 478 -- | Returns the definition(s) for the term at the specified position.
 479 getDefinitions :: MonadIO m
 480                => TextDocumentIdentifier -- ^ The document the term is in.
 481                -> Position -- ^ The position the term is at.
 482                -> SessionT m [Location] -- ^ The location(s) of the definitions
 483 getDefinitions doc pos =
 484   let params = TextDocumentPositionParams doc pos
 485   in getResponseResult <$> sendRequest TextDocumentDefinition params
 486
 487 -- ^ Renames the term at the specified position.
 488 rename :: forall m. MonadIO m => TextDocumentIdentifier -> Position -> String -> SessionT m ()
 489 rename doc pos newName = do
 490   let params = RenameParams doc pos (T.pack newName)
 491   rsp <- sendRequest TextDocumentRename params :: SessionT m RenameResponse
 492   let wEdit = getResponseResult rsp
 493       req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
 494   updateState (ReqApplyWorkspaceEdit req)
 495
 496 -- | Returns the hover information at the specified position.
 497 getHover :: MonadIO m => TextDocumentIdentifier -> Position -> SessionT m (Maybe Hover)
 498 getHover doc pos =
 499   let params = TextDocumentPositionParams doc pos
 500   in getResponseResult <$> sendRequest TextDocumentHover params
 501
 502 -- | Returns the highlighted occurences of the term at the specified position
 503 getHighlights :: MonadIO m => TextDocumentIdentifier -> Position -> SessionT m [DocumentHighlight]
 504 getHighlights doc pos =
 505   let params = TextDocumentPositionParams doc pos
 506   in getResponseResult <$> sendRequest TextDocumentDocumentHighlight params
 507
 508 -- | Checks the response for errors and throws an exception if needed.
 509 -- Returns the result if successful.
 510 getResponseResult :: ResponseMessage a -> a
 511 getResponseResult rsp = fromMaybe exc (rsp ^. result)
 512   where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
 513                                               (fromJust $ rsp ^. LSP.error)
 514
 515 -- | Applies formatting to the specified document.
 516 formatDoc :: MonadIO m => TextDocumentIdentifier -> FormattingOptions -> SessionT m ()
 517 formatDoc doc opts = do
 518   let params = DocumentFormattingParams doc opts
 519   edits <- getResponseResult <$> sendRequest TextDocumentFormatting params
 520   applyTextEdits doc edits
 521
 522 -- | Applies formatting to the specified range in a document.
 523 formatRange :: MonadIO m => TextDocumentIdentifier -> FormattingOptions -> Range -> SessionT m ()
 524 formatRange doc opts range = do
 525   let params = DocumentRangeFormattingParams doc range opts
 526   edits <- getResponseResult <$> sendRequest TextDocumentRangeFormatting params
 527   applyTextEdits doc edits
 528
 529 applyTextEdits :: MonadIO m => TextDocumentIdentifier -> List TextEdit -> SessionT m ()
 530 applyTextEdits doc edits =
 531   let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
 532       req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
 533   in updateState (ReqApplyWorkspaceEdit req)
 534