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