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