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