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