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