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