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