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, error)
  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
 155 -- | Listens to the server output, makes sure it matches the record and
 156 -- signals any semaphores
 157 listenServer :: Handle -> Session ()
 158 listenServer serverOut = do
 159   msgBytes <- liftIO $ getNextMessage serverOut
 160
 161   context <- ask
 162   reqMap <- liftIO $ readMVar $ requestMap context
 163
 164   let msg = decodeFromServerMsg reqMap msgBytes
 165   liftIO $ writeChan (messageChan context) msg
 166
 167   listenServer serverOut
 168
 169 -- | The current text contents of a document.
 170 documentContents :: TextDocumentIdentifier -> Session T.Text
 171 documentContents doc = do
 172   vfs <- vfs <$> get
 173   let file = vfs Map.! (doc ^. uri)
 174   return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
 175
 176 -- | Parses an ApplyEditRequest, checks that it is for the passed document
 177 -- and returns the new content
 178 getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
 179 getDocumentEdit doc = do
 180   req <- request :: Session ApplyWorkspaceEditRequest
 181
 182   unless (checkDocumentChanges req || checkChanges req) $
 183     liftIO $ throw (IncorrectApplyEditRequestException (show req))
 184
 185   documentContents doc
 186   where
 187     checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
 188     checkDocumentChanges req =
 189       let changes = req ^. params . edit . documentChanges
 190           maybeDocs = fmap (fmap (^. textDocument . uri)) changes
 191       in case maybeDocs of
 192         Just docs -> (doc ^. uri) `elem` docs
 193         Nothing -> False
 194     checkChanges :: ApplyWorkspaceEditRequest -> Bool
 195     checkChanges req =
 196       let mMap = req ^. params . edit . changes
 197         in maybe False (HashMap.member (doc ^. uri)) mMap
 198
 199 -- | Sends a request to the server and waits for its response.
 200 -- @
 201 -- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
 202 -- @
 203 -- Note: will skip any messages in between the request and the response.
 204 sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
 205 sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId
 206
 207 -- | Send a request to the server and wait for its response,
 208 -- but discard it.
 209 sendRequest_ :: ToJSON params => ClientMethod -> params -> Session ()
 210 sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value))
 211
 212 -- | Sends a request to the server without waiting on the response.
 213 sendRequest'
 214   :: ToJSON params
 215   => ClientMethod -- ^ The request method.
 216   -> params -- ^ The request parameters.
 217   -> Session LspId -- ^ The id of the request that was sent.
 218 sendRequest' method params = do
 219   id <- curReqId <$> get
 220   modify $ \c -> c { curReqId = nextId id }
 221
 222   let req = RequestMessage' "2.0" id method params
 223
 224   -- Update the request map
 225   reqMap <- requestMap <$> ask
 226   liftIO $ modifyMVar_ reqMap $
 227     \r -> return $ updateRequestMap r id method
 228
 229   sendMessage req
 230
 231   return id
 232
 233   where nextId (IdInt i) = IdInt (i + 1)
 234         nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
 235
 236 -- | A custom type for request message that doesn't
 237 -- need a response type, allows us to infer the request
 238 -- message type without using proxies.
 239 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
 240
 241 instance ToJSON a => ToJSON (RequestMessage' a) where
 242   toJSON (RequestMessage' rpc id method params) =
 243     object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
 244
 245
 246 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 247 sendRequestMessage req = do
 248   -- Update the request map
 249   reqMap <- requestMap <$> ask
 250   liftIO $ modifyMVar_ reqMap $
 251     \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
 252
 253   sendMessage req
 254
 255 -- | Sends a notification to the server.
 256 sendNotification :: ToJSON a
 257                  => ClientMethod -- ^ The notification method.
 258                  -> a -- ^ The notification parameters.
 259                  -> Session ()
 260
 261 -- | Open a virtual file if we send a did open text document notification
 262 sendNotification TextDocumentDidOpen params = do
 263   let params' = fromJust $ decode $ encode params
 264       n :: DidOpenTextDocumentNotification
 265       n = NotificationMessage "2.0" TextDocumentDidOpen params'
 266   oldVFS <- vfs <$> get
 267   newVFS <- liftIO $ openVFS oldVFS n
 268   modify (\s -> s { vfs = newVFS })
 269   sendNotification' n
 270
 271 -- | Close a virtual file if we send a close text document notification
 272 sendNotification TextDocumentDidClose params = do
 273   let params' = fromJust $ decode $ encode params
 274       n :: DidCloseTextDocumentNotification
 275       n = NotificationMessage "2.0" TextDocumentDidClose params'
 276   oldVFS <- vfs <$> get
 277   newVFS <- liftIO $ closeVFS oldVFS n
 278   modify (\s -> s { vfs = newVFS })
 279   sendNotification' n
 280
 281 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
 282
 283 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
 284 sendNotification' = sendMessage
 285
 286 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
 287 sendResponse = sendMessage
 288
 289 -- | Returns the initialize response that was received from the server.
 290 -- The initialize requests and responses are not included the session,
 291 -- so if you need to test it use this.
 292 initializeResponse :: Session InitializeResponse
 293 initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
 294
 295 -- | Opens a text document and sends a notification to the client.
 296 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 297 openDoc file languageId = do
 298   item <- getDocItem file languageId
 299   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
 300   TextDocumentIdentifier <$> getDocUri file
 301   where
 302   -- | Reads in a text document as the first version.
 303   getDocItem :: FilePath -- ^ The path to the text document to read in.
 304             -> String -- ^ The language ID, e.g "haskell" for .hs files.
 305             -> Session TextDocumentItem
 306   getDocItem file languageId = do
 307     context <- ask
 308     let fp = rootDir context </> file
 309     contents <- liftIO $ T.readFile fp
 310     return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
 311
 312 -- | Gets the Uri for the file corrected to the session directory.
 313 getDocUri :: FilePath -> Session Uri
 314 getDocUri file = do
 315   context <- ask
 316   let fp = rootDir context </> file
 317   return $ filePathToUri fp
 318
 319 waitForDiagnostics :: Session [Diagnostic]
 320 waitForDiagnostics = do
 321   diagsNot <- skipManyTill anyMessage notification :: Session PublishDiagnosticsNotification
 322   let (List diags) = diagsNot ^. params . LSP.diagnostics
 323   return diags
 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 <- notification :: Session PublishDiagnosticsNotification
 331   when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException
 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 getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]
 342 getAllCodeActions doc = do
 343   curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get
 344   let ctx = CodeActionContext (List curDiags) Nothing
 345
 346   foldM (go ctx) [] curDiags
 347
 348   where
 349     go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]
 350     go ctx acc diag = do
 351       ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
 352
 353       case mErr of
 354         Just e -> throw (UnexpectedResponseError rspLid e)
 355         Nothing ->
 356           let Just (List cmdOrCAs) = mRes
 357             in return (acc ++ cmdOrCAs)
 358
 359 executeCommand :: Command -> Session ()
 360 executeCommand cmd = do
 361   let args = decode $ encode $ fromJust $ cmd ^. arguments
 362       execParams = ExecuteCommandParams (cmd ^. command) args
 363   sendRequest_ WorkspaceExecuteCommand execParams
 364
 365 executeCodeAction :: CodeAction -> Session ()
 366 executeCodeAction action = do
 367   maybe (return ()) handleEdit $ action ^. edit
 368   maybe (return ()) executeCommand $ action ^. command
 369
 370   where handleEdit :: WorkspaceEdit -> Session ()
 371         handleEdit e =
 372           let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
 373             in processMessage (ReqApplyWorkspaceEdit req)