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