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   , getDocUri
  62   ) where
  63
  64 import Control.Applicative
  65 import Control.Applicative.Combinators
  66 import Control.Monad
  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 Data.Foldable
  76 import qualified Data.HashMap.Strict as HashMap
  77 import Data.List
  78 import Language.Haskell.LSP.Types
  79 import qualified  Language.Haskell.LSP.Types as LSP (error, id)
  80 import Language.Haskell.LSP.TH.ClientCapabilities
  81 import Language.Haskell.LSP.Messages
  82 import Language.Haskell.LSP.VFS
  83 import Language.Haskell.LSP.Test.Compat
  84 import Language.Haskell.LSP.Test.Decoding
  85 import Language.Haskell.LSP.Test.Parsing
  86 import Language.Haskell.LSP.Test.Session
  87 import Language.Haskell.LSP.Test.Server
  88 import System.IO
  89 import System.Directory
  90 import System.FilePath
  91
  92 -- | Starts a new session.
  93 runSession :: String -- ^ The command to run the server.
  94            -> FilePath -- ^ The filepath to the root directory for the session.
  95            -> Session a -- ^ The session to run.
  96            -> IO a
  97 runSession = runSessionWithCapabilities def
  98
  99 -- | Starts a new sesion with a client with the specified capabilities.
 100 runSessionWithCapabilities :: ClientCapabilities -- ^ The capabilities the client should have.
 101                            -> String -- ^ The command to run the server.
 102                            -> FilePath -- ^ The filepath to the root directory for the session.
 103                            -> Session a -- ^ The session to run.
 104                            -> IO a
 105 runSessionWithCapabilities caps serverExe rootDir session = do
 106   pid <- getProcessID
 107   absRootDir <- canonicalizePath rootDir
 108
 109   let initializeParams = InitializeParams (Just pid)
 110                                           (Just $ T.pack absRootDir)
 111                                           (Just $ filePathToUri absRootDir)
 112                                           Nothing
 113                                           caps
 114                                           (Just TraceOff)
 115
 116   withServer serverExe $ \serverIn serverOut _ -> runSessionWithHandles serverIn serverOut listenServer rootDir $ do
 117
 118     -- Wrap the session around initialize and shutdown calls
 119     sendRequest Initialize initializeParams
 120     initRspMsg <- response :: Session InitializeResponse
 121
 122     liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
 123
 124     initRspVar <- initRsp <$> ask
 125     liftIO $ putMVar initRspVar initRspMsg
 126
 127     sendNotification Initialized InitializedParams
 128
 129     -- Run the actual test
 130     result <- session
 131
 132     sendNotification Exit ExitParams
 133
 134     return result
 135
 136 -- | Listens to the server output, makes sure it matches the record and
 137 -- signals any semaphores
 138 listenServer :: Handle -> Session ()
 139 listenServer serverOut = do
 140   msgBytes <- liftIO $ getNextMessage serverOut
 141
 142   context <- ask
 143   reqMap <- liftIO $ readMVar $ requestMap context
 144
 145   let msg = decodeFromServerMsg reqMap msgBytes
 146   processTextChanges msg
 147   liftIO $ writeChan (messageChan context) msg
 148
 149   listenServer serverOut
 150
 151 processTextChanges :: FromServerMessage -> Session ()
 152 processTextChanges (ReqApplyWorkspaceEdit r) = do
 153   List changeParams <- case r ^. params . edit . documentChanges of
 154     Just cs -> mapM applyTextDocumentEdit cs
 155     Nothing -> case r ^. params . edit . changes of
 156       Just cs -> mapM (uncurry applyTextEdit) (List (HashMap.toList cs))
 157       Nothing -> return (List [])
 158
 159   let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) changeParams
 160       mergedParams = map mergeParams groupedParams
 161
 162   forM_ mergedParams (sendNotification TextDocumentDidChange)
 163
 164   where applyTextDocumentEdit (TextDocumentEdit docId (List edits)) = do
 165           oldVFS <- vfs <$> get
 166           let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
 167               params = DidChangeTextDocumentParams docId (List changeEvents)
 168           newVFS <- liftIO $ changeVFS oldVFS (fmClientDidChangeTextDocumentNotification params)
 169           modify (\s -> s { vfs = newVFS })
 170           return params
 171
 172         applyTextEdit uri edits = applyTextDocumentEdit (TextDocumentEdit (VersionedTextDocumentIdentifier uri 0) edits)
 173
 174         mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
 175         mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
 176                              in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
 177 processTextChanges _ = return ()
 178
 179 -- | Sends a request to the server.
 180 --
 181 -- @
 182 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
 183 --             TextDocumentDocumentSymbol
 184 --             (DocumentSymbolParams docId)
 185 -- @
 186 sendRequest
 187   :: (ToJSON params)
 188   => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
 189   ClientMethod -- ^ The request method.
 190   -> params -- ^ The request parameters.
 191   -> Session LspId -- ^ The id of the request that was sent.
 192 sendRequest method params = do
 193   id <- curReqId <$> get
 194   modify $ \c -> c { curReqId = nextId id }
 195
 196   let req = RequestMessage' "2.0" id method params
 197
 198   -- Update the request map
 199   reqMap <- requestMap <$> ask
 200   liftIO $ modifyMVar_ reqMap $
 201     \r -> return $ updateRequestMap r id method
 202
 203   sendMessage req
 204
 205   return id
 206
 207   where nextId (IdInt i) = IdInt (i + 1)
 208         nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
 209
 210 -- | A custom type for request message that doesn't
 211 -- need a response type, allows us to infer the request
 212 -- message type without using proxies.
 213 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
 214
 215 instance ToJSON a => ToJSON (RequestMessage' a) where
 216   toJSON (RequestMessage' rpc id method params) =
 217     object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
 218
 219
 220 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 221 sendRequest' req = do
 222   -- Update the request map
 223   reqMap <- requestMap <$> ask
 224   liftIO $ modifyMVar_ reqMap $
 225     \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
 226
 227   sendMessage req
 228
 229 -- | Sends a notification to the server.
 230 sendNotification :: ToJSON a
 231                  => ClientMethod -- ^ The notification method.
 232                  -> a -- ^ The notification parameters.
 233                  -> Session ()
 234 sendNotification method params =
 235   let notif = NotificationMessage "2.0" method params
 236     in sendNotification' notif
 237
 238 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
 239 sendNotification' = sendMessage
 240
 241 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
 242 sendResponse = sendMessage
 243
 244 sendMessage :: ToJSON a => a -> Session ()
 245 sendMessage msg = do
 246   h <- serverIn <$> ask
 247   liftIO $ B.hPut h $ addHeader (encode msg)
 248
 249 -- | Returns the initialize response that was received from the server.
 250 -- The initialize requests and responses are not included the session,
 251 -- so if you need to test it use this.
 252 getInitializeResponse :: Session InitializeResponse
 253 getInitializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
 254
 255 -- | Opens a text document and sends a notification to the client.
 256 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 257 openDoc file languageId = do
 258   item <- getDocItem file languageId
 259   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
 260   TextDocumentIdentifier <$> getDocUri file
 261
 262 -- | Reads in a text document as the first version.
 263 getDocItem :: FilePath -- ^ The path to the text document to read in.
 264            -> String -- ^ The language ID, e.g "haskell" for .hs files.
 265            -> Session TextDocumentItem
 266 getDocItem file languageId = do
 267   context <- ask
 268   let fp = rootDir context </> file
 269   contents <- liftIO $ T.readFile fp
 270   return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
 271
 272 -- | Gets the Uri for the file corrected to the session directory.
 273 getDocUri :: FilePath -> Session Uri
 274 getDocUri file = do
 275   context <- ask
 276   let fp = rootDir context </> file
 277   return $ filePathToUri fp