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