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