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