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