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