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   let file = vfs Map.! (doc ^. uri)
 157   return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
 158
 159 -- | Parses an ApplyEditRequest, checks that it is for the passed document
 160 -- and returns the new content
 161 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
 162 getDocumentEdit doc = do
 163   req <- message :: Session ApplyWorkspaceEditRequest
 164
 165   unless (checkDocumentChanges req || checkChanges req) $
 166     liftIO $ throw (IncorrectApplyEditRequest (show req))
 167
 168   documentContents doc
 169   where
 170     checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
 171     checkDocumentChanges req =
 172       let changes = req ^. params . edit . documentChanges
 173           maybeDocs = fmap (fmap (^. textDocument . uri)) changes
 174       in case maybeDocs of
 175         Just docs -> (doc ^. uri) `elem` docs
 176         Nothing -> False
 177     checkChanges :: ApplyWorkspaceEditRequest -> Bool
 178     checkChanges req =
 179       let mMap = req ^. params . edit . changes
 180         in maybe False (HashMap.member (doc ^. uri)) mMap
 181
 182 -- | Sends a request to the server and waits for its response.
 183 -- @
 184 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
 185 -- @
 186 -- Note: will skip any messages in between the request and the response.
 187 sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
 188 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
 189
 190 -- | Send a request to the server and wait for its response,
 191 -- but discard it.
 192 sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
 193 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
 194
 195 -- | Sends a request to the server without waiting on the response.
 196 sendRequest'
 197   :: ToJSON params
 198   => ClientMethod -- ^ The request method.
 199   -> params -- ^ The request parameters.
 200   -> Session LspId -- ^ The id of the request that was sent.
 201 sendRequest' method params = do
 202   id <- curReqId <$> get
 203   modify $ \c -> c { curReqId = nextId id }
 204
 205   let req = RequestMessage' "2.0" id method params
 206
 207   -- Update the request map
 208   reqMap <- requestMap <$> ask
 209   liftIO $ modifyMVar_ reqMap $
 210     \r -> return $ updateRequestMap r id method
 211
 212   sendMessage req
 213
 214   return id
 215
 216   where nextId (IdInt i) = IdInt (i + 1)
 217         nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
 218
 219 -- | A custom type for request message that doesn't
 220 -- need a response type, allows us to infer the request
 221 -- message type without using proxies.
 222 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
 223
 224 instance ToJSON a => ToJSON (RequestMessage' a) where
 225   toJSON (RequestMessage' rpc id method params) =
 226     object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
 227
 228
 229 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 230 sendRequestMessage req = do
 231   -- Update the request map
 232   reqMap <- requestMap <$> ask
 233   liftIO $ modifyMVar_ reqMap $
 234     \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
 235
 236   sendMessage req
 237
 238 -- | Sends a notification to the server.
 239 sendNotification :: ToJSON a
 240                  => ClientMethod -- ^ The notification method.
 241                  -> a -- ^ The notification parameters.
 242                  -> Session ()
 243
 244 -- | Open a virtual file if we send a did open text document notification
 245 sendNotification TextDocumentDidOpen params = do
 246   let params' = fromJust $ decode $ encode params
 247       n :: DidOpenTextDocumentNotification
 248       n = NotificationMessage "2.0" TextDocumentDidOpen params'
 249   oldVFS <- vfs <$> get
 250   newVFS <- liftIO $ openVFS oldVFS n
 251   modify (\s -> s { vfs = newVFS })
 252   sendNotification' n
 253
 254 -- | Close a virtual file if we send a close text document notification
 255 sendNotification TextDocumentDidClose params = do
 256   let params' = fromJust $ decode $ encode params
 257       n :: DidCloseTextDocumentNotification
 258       n = NotificationMessage "2.0" TextDocumentDidClose params'
 259   oldVFS <- vfs <$> get
 260   newVFS <- liftIO $ closeVFS oldVFS n
 261   modify (\s -> s { vfs = newVFS })
 262   sendNotification' n
 263
 264 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
 265
 266 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
 267 sendNotification' = sendMessage
 268
 269 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
 270 sendResponse = sendMessage
 271
 272 -- | Returns the initialize response that was received from the server.
 273 -- The initialize requests and responses are not included the session,
 274 -- so if you need to test it use this.
 275 initializeResponse :: Session InitializeResponse
 276 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
 277
 278 -- | Opens a text document and sends a notification to the client.
 279 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 280 openDoc file languageId = do
 281   item <- getDocItem file languageId
 282   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
 283   TextDocumentIdentifier <$> getDocUri file
 284   where
 285   -- | Reads in a text document as the first version.
 286   getDocItem :: FilePath -- ^ The path to the text document to read in.
 287             -> String -- ^ The language ID, e.g "haskell" for .hs files.
 288             -> Session TextDocumentItem
 289   getDocItem file languageId = do
 290     context <- ask
 291     let fp = rootDir context </> file
 292     contents <- liftIO $ T.readFile fp
 293     return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
 294
 295 -- | Gets the Uri for the file corrected to the session directory.
 296 getDocUri :: FilePath -> Session Uri
 297 getDocUri file = do
 298   context <- ask
 299   let fp = rootDir context </> file
 300   return $ filePathToUri fp
 301
 302 -- | Waits for diagnostics to be published and returns them.
 303 waitForDiagnostics :: Session [Diagnostic]
 304 waitForDiagnostics = do
 305   diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
 306   let (List diags) = diagsNot ^. params . LSP.diagnostics
 307   return diags
 308
 309 -- | Expects a 'PublishDiagnosticsNotification' and throws an
 310 -- 'UnexpectedDiagnosticsException' if there are any diagnostics
 311 -- returned.
 312 noDiagnostics :: Session ()
 313 noDiagnostics = do
 314   diagsNot <- message :: Session PublishDiagnosticsNotification
 315   when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
 316
 317 -- | Returns the symbols in a document.
 318 getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
 319 getDocumentSymbols doc = do
 320   ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
 321   maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
 322   let (Just (List symbols)) = mRes
 323   return symbols
 324
 325 -- | Returns all the code actions in a document by
 326 -- querying the code actions at each of the current
 327 -- diagnostics' positions.
 328 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
 329 getAllCodeActions doc = do
 330   curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
 331   let ctx = CodeActionContext (List curDiags) Nothing
 332
 333   foldM (go ctx) [] curDiags
 334
 335   where
 336     go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
 337     go ctx acc diag = do
 338       ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
 339
 340       case mErr of
 341         Just e -> throw (UnexpectedResponseError rspLid e)
 342         Nothing ->
 343           let Just (List cmdOrCAs) = mRes
 344             in return (acc ++ cmdOrCAs)
 345
 346 -- | Executes a command.
 347 executeCommand :: Command -> Session ()
 348 executeCommand cmd = do
 349   let args = decode $ encode $ fromJust $ cmd ^. arguments
 350       execParams = ExecuteCommandParams (cmd ^. command) args
 351   sendRequest_ WorkspaceExecuteCommand execParams
 352
 353 -- | Executes a code action.
 354 -- Matching with the specification, if a code action
 355 -- contains both an edit and a command, the edit will
 356 -- be applied first.
 357 executeCodeAction :: CodeAction -> Session ()
 358 executeCodeAction action = do
 359   maybe (return ()) handleEdit $ action ^. edit
 360   maybe (return ()) executeCommand $ action ^. command
 361
 362   where handleEdit :: WorkspaceEdit -> Session ()
 363         handleEdit e =
 364           -- Its ok to pass in dummy parameters here as they aren't used
 365           let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
 366             in updateState (ReqApplyWorkspaceEdit req)
 367
 368 -- | Adds the current version to the document, as tracked by the session.
 369 getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
 370 getVersionedDoc (TextDocumentIdentifier uri) = do
 371   fs <- vfs <$> get
 372   let ver =
 373         case fs Map.!? uri of
 374           Just (VirtualFile v _) -> Just v
 375           _ -> Nothing
 376   return (VersionedTextDocumentIdentifier uri ver)
 377
 378 -- | Applys an edit to the document and returns the updated document version.
 379 applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier
 380 applyEdit doc edit = do
 381
 382   verDoc <- getVersionedDoc doc
 383
 384   caps <- asks (capabilities . config)
 385
 386   let supportsDocChanges = fromMaybe False $ do
 387         let LSP.ClientCapabilities mWorkspace _ _ = caps
 388         LSP.WorkspaceClientCapabilities _ mEdit _ _ _ _ <- mWorkspace
 389         LSP.WorkspaceEditClientCapabilities mDocChanges <- mEdit
 390         mDocChanges
 391
 392   let wEdit = if supportsDocChanges
 393       then
 394         let docEdit = TextDocumentEdit verDoc (List [edit])
 395         in WorkspaceEdit Nothing (Just (List [docEdit]))
 396       else
 397         let changes = HashMap.singleton (doc ^. uri) (List [edit])
 398         in WorkspaceEdit (Just changes) Nothing
 399
 400   let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
 401   updateState (ReqApplyWorkspaceEdit req)
 402
 403   -- version may have changed
 404   getVersionedDoc doc
 405
 406 -- | Returns the completions for the position in the document.
 407 getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
 408 getCompletions doc pos = do
 409   rsp <- sendRequest TextDocumentCompletion (TextDocumentPositionParams doc pos)
 410
 411   let exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)
 412                                             (fromJust $ rsp ^. LSP.error)
 413       res = fromMaybe exc (rsp ^. result)
 414   case res of
 415     Completions (List items) -> return items
 416     CompletionList (CompletionListType _ (List items)) -> return items