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