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 (Either [DocumentSymbol] [SymbolInformation])
 353 getDocumentSymbols doc = do
 354   ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc) :: Session DocumentSymbolsResponse
 355   maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
 356   case mRes of
 357     Just (DSDocumentSymbols (List xs)) -> return (Left xs)
 358     Just (DSSymbolInformation (List xs)) -> return (Right xs)
 359     Nothing -> Prelude.error "No result and no error in DocumentSymbolsResponse"
 360
 361 -- | Returns all the code actions in a document by
 362 -- querying the code actions at each of the current
 363 -- diagnostics' positions.
 364 getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
 365 getAllCodeActions doc = do
 366   curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
 367   let ctx = CodeActionContext (List curDiags) Nothing
 368
 369   foldM (go ctx) [] curDiags
 370
 371   where
 372     go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
 373     go ctx acc diag = do
 374       ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
 375
 376       case mErr of
 377         Just e -> throw (UnexpectedResponseError rspLid e)
 378         Nothing ->
 379           let Just (List cmdOrCAs) = mRes
 380             in return (acc ++ cmdOrCAs)
 381
 382 -- | Executes a command.
 383 executeCommand :: Command -> Session ()
 384 executeCommand cmd = do
 385   let args = decode $ encode $ fromJust $ cmd ^. arguments
 386       execParams = ExecuteCommandParams (cmd ^. command) args
 387   request_ WorkspaceExecuteCommand execParams
 388
 389 -- | Executes a code action.
 390 -- Matching with the specification, if a code action
 391 -- contains both an edit and a command, the edit will
 392 -- be applied first.
 393 executeCodeAction :: CodeAction -> Session ()
 394 executeCodeAction action = do
 395   maybe (return ()) handleEdit $ action ^. edit
 396   maybe (return ()) executeCommand $ action ^. command
 397
 398   where handleEdit :: WorkspaceEdit -> Session ()
 399         handleEdit e =
 400           -- Its ok to pass in dummy parameters here as they aren't used
 401           let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
 402             in updateState (ReqApplyWorkspaceEdit req)
 403
 404 -- | Adds the current version to the document, as tracked by the session.
 405 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
 406 getVersionedDoc (TextDocumentIdentifier uri) = do
 407   fs <- vfs <$> get
 408   let ver =
 409         case fs Map.!? uri of
 410           Just (VirtualFile v _) -> Just v
 411           _ -> Nothing
 412   return (VersionedTextDocumentIdentifier uri ver)
 413
 414 -- | Applys an edit to the document and returns the updated document version.
 415 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
 416 applyEdit doc edit = do
 417
 418   verDoc <- getVersionedDoc doc
 419
 420   caps <- asks sessionCapabilities
 421
 422   let supportsDocChanges = fromMaybe False $ do
 423         let ClientCapabilities mWorkspace _ _ = caps
 424         WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
 425         WorkspaceEditClientCapabilities mDocChanges <- mEdit
 426         mDocChanges
 427
 428   let wEdit = if supportsDocChanges
 429       then
 430         let docEdit = TextDocumentEdit verDoc (List [edit])
 431         in WorkspaceEdit Nothing (Just (List [docEdit]))
 432       else
 433         let changes = HashMap.singleton (doc ^. uri) (List [edit])
 434         in WorkspaceEdit (Just changes) Nothing
 435
 436   let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
 437   updateState (ReqApplyWorkspaceEdit req)
 438
 439   -- version may have changed
 440   getVersionedDoc doc
 441
 442 -- | Returns the completions for the position in the document.
 443 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
 444 getCompletions doc pos = do
 445   rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos)
 446
 447   case getResponseResult rsp of
 448     Completions (List items) -> return items
 449     CompletionList (CompletionListType _ (List items)) -> return items
 450
 451 -- | Returns the references for the position in the document.
 452 getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.
 453               -> Position -- ^ The position to lookup.
 454               -> Bool -- ^ Whether to include declarations as references.
 455               -> Session [Location] -- ^ The locations of the references.
 456 getReferences doc pos inclDecl =
 457   let ctx = ReferenceContext inclDecl
 458       params = ReferenceParams doc pos ctx
 459   in getResponseResult <$> request TextDocumentReferences params
 460
 461 -- | Returns the definition(s) for the term at the specified position.
 462 getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
 463                -> Position -- ^ The position the term is at.
 464                -> Session [Location] -- ^ The location(s) of the definitions
 465 getDefinitions doc pos =
 466   let params = TextDocumentPositionParams doc pos
 467   in getResponseResult <$> request TextDocumentDefinition params
 468
 469 -- | Renames the term at the specified position.
 470 rename :: TextDocumentIdentifier -> Position -> String -> Session ()
 471 rename doc pos newName = do
 472   let params = RenameParams doc pos (T.pack newName)
 473   rsp <- request TextDocumentRename params :: Session RenameResponse
 474   let wEdit = getResponseResult rsp
 475       req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
 476   updateState (ReqApplyWorkspaceEdit req)
 477
 478 -- | Returns the hover information at the specified position.
 479 getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
 480 getHover doc pos =
 481   let params = TextDocumentPositionParams doc pos
 482   in getResponseResult <$> request TextDocumentHover params
 483
 484 -- | Returns the highlighted occurences of the term at the specified position
 485 getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
 486 getHighlights doc pos =
 487   let params = TextDocumentPositionParams doc pos
 488   in getResponseResult <$> request TextDocumentDocumentHighlight params
 489
 490 -- | Checks the response for errors and throws an exception if needed.
 491 -- Returns the result if successful.
 492 getResponseResult :: ResponseMessage a -> a
 493 getResponseResult rsp = fromMaybe exc (rsp ^. result)
 494   where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
 495                                               (fromJust $ rsp ^. LSP.error)
 496
 497 -- | Applies formatting to the specified document.
 498 formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
 499 formatDoc doc opts = do
 500   let params = DocumentFormattingParams doc opts
 501   edits <- getResponseResult <$> request TextDocumentFormatting params
 502   applyTextEdits doc edits
 503
 504 -- | Applies formatting to the specified range in a document.
 505 formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
 506 formatRange doc opts range = do
 507   let params = DocumentRangeFormattingParams doc range opts
 508   edits <- getResponseResult <$> request TextDocumentRangeFormatting params
 509   applyTextEdits doc edits
 510
 511 applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
 512 applyTextEdits doc edits =
 513   let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
 514       req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
 515   in updateState (ReqApplyWorkspaceEdit req)