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   , runSessionWithHandler
  19   , Session
  20   -- * Sending
  21   , sendRequest
  22   , sendNotification
  23   , sendRequest'
  24   , sendNotification'
  25   , sendResponse
  26   -- * Receving
  27   , request
  28   , response
  29   , notification
  30   , loggingNotification
  31   , publishDiagnosticsNotification
  32   -- * Combinators
  33   , choice
  34   , option
  35   , optional
  36   , skipOptional
  37   , between
  38   , some
  39   , many
  40   , sepBy
  41   , sepBy1
  42   , sepByNonEmpty
  43   , sepEndBy1
  44   , sepEndByNonEmpty
  45   , sepEndBy
  46   , endBy1
  47   , endByNonEmpty
  48   , endBy
  49   , count
  50   , chainl
  51   , chainr
  52   , chainl1
  53   , chainr1
  54   , manyTill
  55   , try
  56   , (<?>)
  57   , skipMany
  58   , skipSome
  59   , unexpected
  60   , notFollowedBy
  61   , (<|>)
  62   , satisfy
  63   -- * Utilities
  64   , openDoc
  65   , getDocItem
  66   , getDocUri
  67   ) where
  68
  69 import Control.Applicative
  70 import Control.Monad
  71 import Control.Monad.IO.Class
  72 import Control.Concurrent
  73 import Control.Lens
  74 import qualified Data.Text as T
  75 import qualified Data.Text.IO as T
  76 import Data.Aeson
  77 import qualified Data.ByteString.Lazy.Char8 as B
  78 import Data.Default
  79 import Data.Proxy
  80 import System.Process
  81 import Language.Haskell.LSP.Types
  82 import qualified  Language.Haskell.LSP.Types as LSP (error)
  83 import Language.Haskell.LSP.Messages
  84 import Language.Haskell.LSP.Test.Compat
  85 import System.IO
  86 import System.Directory
  87 import System.FilePath
  88 import Language.Haskell.LSP.Test.Decoding
  89 import Language.Haskell.LSP.Test.Parsing
  90 import Text.Parser.Combinators
  91
  92 -- | Starts a new session.
  93 runSession :: FilePath -- ^ The filepath to the root directory for the session.
  94            -> Session a -- ^ The session to run.
  95            -> IO ()
  96 runSession rootDir session = do
  97   pid <- getProcessID
  98   absRootDir <- canonicalizePath rootDir
  99
 100   let initializeParams = InitializeParams (Just pid)
 101                                           (Just $ T.pack absRootDir)
 102                                           (Just $ filePathToUri absRootDir)
 103                                           Nothing
 104                                           def
 105                                           (Just TraceOff)
 106
 107   runSessionWithHandler listenServer rootDir $ do
 108
 109     -- Wrap the session around initialize and shutdown calls
 110     sendRequest (Proxy :: Proxy InitializeRequest) Initialize initializeParams
 111     RspInitialize initRsp <- response
 112     liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRsp ^. LSP.error)
 113
 114     sendNotification Initialized InitializedParams
 115
 116     -- Run the actual test
 117     session
 118
 119     sendNotification Exit ExitParams
 120
 121 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
 122 -- It also does not automatically send initialize and exit messages.
 123 runSessionWithHandler :: (Handle -> Session ())
 124                       -> FilePath
 125                       -> Session a
 126                       -> IO a
 127 runSessionWithHandler serverHandler rootDir session = do
 128   absRootDir <- canonicalizePath rootDir
 129
 130   (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess
 131     (proc "hie" ["--lsp", "-d", "-l", "/tmp/hie-test.log"])
 132     { std_in = CreatePipe, std_out = CreatePipe }
 133
 134   hSetBuffering serverIn  NoBuffering
 135   hSetBuffering serverOut NoBuffering
 136
 137   reqMap <- newMVar newRequestMap
 138   messageChan <- newChan
 139   meaninglessChan <- newChan
 140
 141   let context = SessionContext serverIn absRootDir messageChan reqMap
 142       initState = SessionState (IdInt 9)
 143
 144   forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
 145   (result, _) <- runSession' messageChan context initState session
 146
 147   terminateProcess serverProc
 148
 149   return result
 150
 151 -- | Listens to the server output, makes sure it matches the record and
 152 -- signals any semaphores
 153 listenServer :: Handle -> Session ()
 154 listenServer serverOut = do
 155   msgBytes <- liftIO $ getNextMessage serverOut
 156
 157   context <- ask
 158   reqMap <- liftIO $ readMVar $ requestMap context
 159
 160   liftIO $ writeChan (messageChan context) $ decodeFromServerMsg reqMap msgBytes
 161
 162   listenServer serverOut
 163
 164 -- | Sends a request to the server.
 165 --
 166 -- @
 167 -- sendRequest (Proxy :: Proxy DocumentSymbolRequest)
 168 --             TextDocumentDocumentSymbol
 169 --             (DocumentSymbolParams docId)
 170 -- @
 171 sendRequest
 172   :: forall params resp. (ToJSON params, ToJSON resp, FromJSON resp)
 173   => Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
 174   -> ClientMethod -- ^ The request method.
 175   -> params -- ^ The request parameters.
 176   -> Session LspId -- ^ The id of the request that was sent.
 177 sendRequest _ method params = do
 178   id <- curReqId <$> get
 179   modify $ \c -> c { curReqId = nextId id }
 180
 181   let req = RequestMessage "2.0" id method params :: RequestMessage ClientMethod params resp
 182
 183   sendRequest' req
 184
 185   return id
 186
 187   where nextId (IdInt i) = IdInt (i + 1)
 188         nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
 189
 190 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 191 sendRequest' req = do
 192   -- Update the request map
 193   reqMap <- requestMap <$> ask
 194   liftIO $ modifyMVar_ reqMap (return . flip updateRequestMap req)
 195
 196   sendMessage req
 197
 198 -- | Sends a notification to the server.
 199 sendNotification :: ToJSON a
 200                  => ClientMethod -- ^ The notification method.
 201                  -> a -- ^ The notification parameters.
 202                  -> Session ()
 203 sendNotification method params =
 204   let notif = NotificationMessage "2.0" method params
 205     in sendNotification' notif
 206
 207 sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session ()
 208 sendNotification' = sendMessage
 209
 210 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
 211 sendResponse = sendMessage
 212
 213 sendMessage :: ToJSON a => a -> Session ()
 214 sendMessage msg = do
 215   h <- serverIn <$> ask
 216   liftIO $ B.hPut h $ addHeader (encode msg)
 217
 218 -- | Opens a text document and sends a notification to the client.
 219 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 220 openDoc file languageId = do
 221   item <- getDocItem file languageId
 222   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
 223   TextDocumentIdentifier <$> getDocUri file
 224
 225 -- | Reads in a text document as the first version.
 226 getDocItem :: FilePath -- ^ The path to the text document to read in.
 227            -> String -- ^ The language ID, e.g "haskell" for .hs files.
 228            -> Session TextDocumentItem
 229 getDocItem file languageId = do
 230   context <- ask
 231   let fp = rootDir context </> file
 232   contents <- liftIO $ T.readFile fp
 233   return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
 234
 235 -- | Gets the Uri for the file corrected to the session directory.
 236 getDocUri :: FilePath -> Session Uri
 237 getDocUri file = do
 238   context <- ask
 239   let fp = rootDir context </> file
 240   return $ filePathToUri fp