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