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