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