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