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