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   , sendNotification
  28   , sendRequest'
  29   , sendNotification'
  30   , sendResponse
  31   -- * Receving
  32   , anyRequest
  33   , request
  34   , anyResponse
  35   , response
  36   , anyNotification
  37   , notification
  38   , loggingNotification
  39   , publishDiagnosticsNotification
  40   -- * Combinators
  41   , choice
  42   , option
  43   , optional
  44   , between
  45   , some
  46   , many
  47   , sepBy
  48   , sepBy1
  49   , sepEndBy1
  50   , sepEndBy
  51   , endBy1
  52   , endBy
  53   , count
  54   , manyTill
  55   , skipMany
  56   , skipSome
  57   , skipManyTill
  58   , skipSomeTill
  59   , (<|>)
  60   , satisfy
  61   -- * Utilities
  62   , getInitializeResponse
  63   , openDoc
  64   , getDocItem
  65   , documentContents
  66   , getDocUri
  67   ) where
  68
  69 import Control.Applicative
  70 import Control.Applicative.Combinators
  71 import Control.Monad.IO.Class
  72 import Control.Concurrent
  73 import Control.Lens hiding ((.=), List)
  74 import qualified Data.Text as T
  75 import qualified Data.Text.IO as T
  76 import Data.Aeson
  77 import qualified Data.ByteString.Lazy.Char8 as B
  78 import Data.Default
  79 import qualified Data.Map as Map
  80 import Data.Maybe
  81 import Language.Haskell.LSP.Types hiding (id, capabilities)
  82 import qualified Language.Haskell.LSP.Types as LSP
  83 import Language.Haskell.LSP.VFS
  84 import Language.Haskell.LSP.Test.Compat
  85 import Language.Haskell.LSP.Test.Decoding
  86 import Language.Haskell.LSP.Test.Exceptions
  87 import Language.Haskell.LSP.Test.Parsing
  88 import Language.Haskell.LSP.Test.Session
  89 import Language.Haskell.LSP.Test.Server
  90 import System.IO
  91 import System.Directory
  92 import System.FilePath
  93 import qualified Yi.Rope as Rope
  94
  95 -- | Starts a new session.
  96 runSession :: String -- ^ The command to run the server.
  97            -> FilePath -- ^ The filepath to the root directory for the session.
  98            -> Session a -- ^ The session to run.
  99            -> IO a
 100 runSession = runSessionWithConfig def
 101
 102 -- | Starts a new sesion with a client with the specified capabilities.
 103 runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have.
 104                      -> String -- ^ The command to run the server.
 105                      -> FilePath -- ^ The filepath to the root directory for the session.
 106                      -> Session a -- ^ The session to run.
 107                      -> IO a
 108 runSessionWithConfig config serverExe rootDir session = do
 109   pid <- getProcessID
 110   absRootDir <- canonicalizePath rootDir
 111
 112   let initializeParams = InitializeParams (Just pid)
 113                                           (Just $ T.pack absRootDir)
 114                                           (Just $ filePathToUri absRootDir)
 115                                           Nothing
 116                                           (capabilities config)
 117                                           (Just TraceOff)
 118
 119   withServer serverExe $ \serverIn serverOut _ ->
 120     runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
 121
 122       -- Wrap the session around initialize and shutdown calls
 123       sendRequest Initialize initializeParams
 124       initRspMsg <- response :: Session InitializeResponse
 125
 126       liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
 127
 128       initRspVar <- initRsp <$> ask
 129       liftIO $ putMVar initRspVar initRspMsg
 130
 131       sendNotification Initialized InitializedParams
 132
 133       -- Run the actual test
 134       result <- session
 135
 136       sendNotification Exit ExitParams
 137
 138       return result
 139
 140 -- | Listens to the server output, makes sure it matches the record and
 141 -- signals any semaphores
 142 listenServer :: Handle -> Session ()
 143 listenServer serverOut = do
 144   msgBytes <- liftIO $ getNextMessage serverOut
 145
 146   context <- ask
 147   reqMap <- liftIO $ readMVar $ requestMap context
 148
 149   let msg = decodeFromServerMsg reqMap msgBytes
 150   liftIO $ writeChan (messageChan context) msg
 151
 152   listenServer serverOut
 153
 154 -- | The current text contents of a document.
 155 documentContents :: TextDocumentIdentifier -> Session T.Text
 156 documentContents doc = do
 157   vfs <- vfs <$> get
 158   let file = vfs Map.! (doc ^. uri)
 159   return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
 160
 161 -- | Sends a request to the server.
 162 --
 163 -- @
 164 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
 165 --             TextDocumentDocumentSymbol
 166 --             (DocumentSymbolParams docId)
 167 -- @
 168 sendRequest
 169   :: (ToJSON params)
 170   => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
 171   ClientMethod -- ^ The request method.
 172   -> params -- ^ The request parameters.
 173   -> Session LspId -- ^ The id of the request that was sent.
 174 sendRequest method params = do
 175   id <- curReqId <$> get
 176   modify $ \c -> c { curReqId = nextId id }
 177
 178   let req = RequestMessage' "2.0" id method params
 179
 180   -- Update the request map
 181   reqMap <- requestMap <$> ask
 182   liftIO $ modifyMVar_ reqMap $
 183     \r -> return $ updateRequestMap r id method
 184
 185   sendMessage req
 186
 187   return id
 188
 189   where nextId (IdInt i) = IdInt (i + 1)
 190         nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
 191
 192 -- | A custom type for request message that doesn't
 193 -- need a response type, allows us to infer the request
 194 -- message type without using proxies.
 195 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
 196
 197 instance ToJSON a => ToJSON (RequestMessage' a) where
 198   toJSON (RequestMessage' rpc id method params) =
 199     object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
 200
 201
 202 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 203 sendRequest' req = do
 204   -- Update the request map
 205   reqMap <- requestMap <$> ask
 206   liftIO $ modifyMVar_ reqMap $
 207     \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
 208
 209   sendMessage req
 210
 211 -- | Sends a notification to the server.
 212 sendNotification :: ToJSON a
 213                  => ClientMethod -- ^ The notification method.
 214                  -> a -- ^ The notification parameters.
 215                  -> Session ()
 216
 217 -- | Open a virtual file if we send a did open text document notification
 218 sendNotification TextDocumentDidOpen params = do
 219   let params' = fromJust $ decode $ encode params
 220       n :: DidOpenTextDocumentNotification
 221       n = NotificationMessage "2.0" TextDocumentDidOpen params'
 222   oldVFS <- vfs <$> get
 223   newVFS <- liftIO $ openVFS oldVFS n
 224   modify (\s -> s { vfs = newVFS })
 225   sendNotification' n
 226
 227 -- | Close a virtual file if we send a close text document notification
 228 sendNotification TextDocumentDidClose params = do
 229   let params' = fromJust $ decode $ encode params
 230       n :: DidCloseTextDocumentNotification
 231       n = NotificationMessage "2.0" TextDocumentDidClose params'
 232   oldVFS <- vfs <$> get
 233   newVFS <- liftIO $ closeVFS oldVFS n
 234   modify (\s -> s { vfs = newVFS })
 235   sendNotification' n
 236
 237 sendNotification method params = sendNotification' (NotificationMessage "2.0" method params)
 238
 239 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
 240 sendNotification' = sendMessage
 241
 242 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
 243 sendResponse = sendMessage
 244
 245 sendMessage :: ToJSON a => a -> Session ()
 246 sendMessage msg = do
 247   h <- serverIn <$> ask
 248   liftIO $ B.hPut h $ addHeader (encode msg)
 249
 250 -- | Returns the initialize response that was received from the server.
 251 -- The initialize requests and responses are not included the session,
 252 -- so if you need to test it use this.
 253 getInitializeResponse :: Session InitializeResponse
 254 getInitializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
 255
 256 -- | Opens a text document and sends a notification to the client.
 257 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 258 openDoc file languageId = do
 259   item <- getDocItem file languageId
 260   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
 261   TextDocumentIdentifier <$> getDocUri file
 262
 263 -- | Reads in a text document as the first version.
 264 getDocItem :: FilePath -- ^ The path to the text document to read in.
 265            -> String -- ^ The language ID, e.g "haskell" for .hs files.
 266            -> Session TextDocumentItem
 267 getDocItem file languageId = do
 268   context <- ask
 269   let fp = rootDir context </> file
 270   contents <- liftIO $ T.readFile fp
 271   return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
 272
 273 -- | Gets the Uri for the file corrected to the session directory.
 274 getDocUri :: FilePath -> Session Uri
 275 getDocUri file = do
 276   context <- ask
 277   let fp = rootDir context </> file
 278   return $ filePathToUri fp
 279