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