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