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