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           liftIO $ print newVFS
 161           return params
 162
 163         applyTextEdit uri edits = applyTextDocumentEdit (TextDocumentEdit (VersionedTextDocumentIdentifier uri 0) edits)
 164
 165         mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
 166         mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
 167                              in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
 168 processTextChanges _ = return ()
 169
 170 -- | Sends a request to the server.
 171 --
 172 -- @
 173 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
 174 --             TextDocumentDocumentSymbol
 175 --             (DocumentSymbolParams docId)
 176 -- @
 177 sendRequest
 178   :: (ToJSON params)
 179   => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
 180   ClientMethod -- ^ The request method.
 181   -> params -- ^ The request parameters.
 182   -> Session LspId -- ^ The id of the request that was sent.
 183 sendRequest method params = do
 184   id <- curReqId <$> get
 185   modify $ \c -> c { curReqId = nextId id }
 186
 187   let req = RequestMessage' "2.0" id method params
 188
 189   -- Update the request map
 190   reqMap <- requestMap <$> ask
 191   liftIO $ modifyMVar_ reqMap $
 192     \r -> return $ updateRequestMap r id method
 193
 194   sendMessage req
 195
 196   return id
 197
 198   where nextId (IdInt i) = IdInt (i + 1)
 199         nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
 200
 201 -- | A custom type for request message that doesn't
 202 -- need a response type, allows us to infer the request
 203 -- message type without using proxies.
 204 data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
 205
 206 instance ToJSON a => ToJSON (RequestMessage' a) where
 207   toJSON (RequestMessage' rpc id method params) =
 208     object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
 209
 210
 211 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 212 sendRequest' req = do
 213   -- Update the request map
 214   reqMap <- requestMap <$> ask
 215   liftIO $ modifyMVar_ reqMap $
 216     \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
 217
 218   sendMessage req
 219
 220 -- | Sends a notification to the server.
 221 sendNotification :: ToJSON a
 222                  => ClientMethod -- ^ The notification method.
 223                  -> a -- ^ The notification parameters.
 224                  -> Session ()
 225 sendNotification method params =
 226   let notif = NotificationMessage "2.0" method params
 227     in sendNotification' notif
 228
 229 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
 230 sendNotification' = sendMessage
 231
 232 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
 233 sendResponse = sendMessage
 234
 235 sendMessage :: ToJSON a => a -> Session ()
 236 sendMessage msg = do
 237   h <- serverIn <$> ask
 238   liftIO $ B.hPut h $ addHeader (encode msg)
 239
 240 -- | Returns the initialize response that was received from the server.
 241 -- The initialize requests and responses are not included the session,
 242 -- so if you need to test it use this.
 243 getInitializeResponse :: Session InitializeResponse
 244 getInitializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
 245
 246 -- | Opens a text document and sends a notification to the client.
 247 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 248 openDoc file languageId = do
 249   item <- getDocItem file languageId
 250   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
 251   TextDocumentIdentifier <$> getDocUri file
 252
 253 -- | Reads in a text document as the first version.
 254 getDocItem :: FilePath -- ^ The path to the text document to read in.
 255            -> String -- ^ The language ID, e.g "haskell" for .hs files.
 256            -> Session TextDocumentItem
 257 getDocItem file languageId = do
 258   context <- ask
 259   let fp = rootDir context </> file
 260   contents <- liftIO $ T.readFile fp
 261   return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
 262
 263 -- | Gets the Uri for the file corrected to the session directory.
 264 getDocUri :: FilePath -> Session Uri
 265 getDocUri file = do
 266   context <- ask
 267   let fp = rootDir context </> file
 268   return $ filePathToUri fp