Add getInitializeResponse

[lsp-test.git] / src / Language / Haskell / LSP / Test.hs

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index 068fc2dd0a3cbc17e9da1b98b0f92c5238263f5b..8da0cbbee8ba065533e8e0d06ac79e3f35ee4612 100644 (file)
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -24,75 +24,69 @@ module Language.Haskell.LSP.Test
   , sendNotification'
   , sendResponse
   -- * Receving
   , sendNotification'
   , sendResponse
   -- * Receving

+  , anyRequest

   , request
   , request

+  , anyResponse

   , response
   , response

+  , anyNotification

   , notification
   , loggingNotification
   , notification
   , loggingNotification

+  , publishDiagnosticsNotification

   -- * Combinators
   , choice
   , option
   , optional
   -- * Combinators
   , choice
   , option
   , optional

-  , skipOptional

   , between
   , some
   , many
   , sepBy
   , sepBy1
   , between
   , some
   , many
   , sepBy
   , sepBy1

-  , sepByNonEmpty

   , sepEndBy1
   , sepEndBy1

-  , sepEndByNonEmpty

   , sepEndBy
   , endBy1
   , sepEndBy
   , endBy1

-  , endByNonEmpty

   , endBy
   , count
   , endBy
   , count

-  , chainl
-  , chainr
-  , chainl1
-  , chainr1

   , manyTill
   , manyTill

-  , try
-  , (<?>)

   , skipMany
   , skipSome
   , skipMany
   , skipSome

-  , unexpected
-  , notFollowedBy
+  , skipManyTill
+  , skipSomeTill

   , (<|>)
   , satisfy
   -- * Utilities
   , (<|>)
   , satisfy
   -- * Utilities

+  , getInitializeResponse

   , openDoc
   , getDocItem
   , getDocUri
   ) where
 
 import Control.Applicative
   , openDoc
   , getDocItem
   , getDocUri
   ) where
 
 import Control.Applicative

+import Control.Applicative.Combinators

 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Concurrent
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Concurrent

-import Control.Lens
+import Control.Lens hiding ((.=))

 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Data.Aeson
 import qualified Data.ByteString.Lazy.Char8 as B
 import Data.Default
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Data.Aeson
 import qualified Data.ByteString.Lazy.Char8 as B
 import Data.Default

-import Data.Proxy

 import System.Process
 import Language.Haskell.LSP.Types
 import System.Process
 import Language.Haskell.LSP.Types

-import qualified  Language.Haskell.LSP.Types as LSP (error)
-import Language.Haskell.LSP.Messages
+import qualified  Language.Haskell.LSP.Types as LSP (error, id)

 import Language.Haskell.LSP.Test.Compat
 import System.IO
 import System.Directory
 import System.FilePath
 import Language.Haskell.LSP.Test.Decoding
 import Language.Haskell.LSP.Test.Parsing
 import Language.Haskell.LSP.Test.Compat
 import System.IO
 import System.Directory
 import System.FilePath
 import Language.Haskell.LSP.Test.Decoding
 import Language.Haskell.LSP.Test.Parsing

-import Text.Parser.Combinators

 
 -- | Starts a new session.
 
 -- | Starts a new session.

-runSession :: FilePath -- ^ The filepath to the root directory for the session.
+runSession :: String -- ^ The command to run the server.
+           -> FilePath -- ^ The filepath to the root directory for the session.

            -> Session a -- ^ The session to run.
            -> IO ()
            -> Session a -- ^ The session to run.
            -> IO ()

-runSession rootDir session = do
+runSession serverExe rootDir session = do

   pid <- getProcessID
   absRootDir <- canonicalizePath rootDir
 
   pid <- getProcessID
   absRootDir <- canonicalizePath rootDir
 


@@ -103,12 +97,17 @@ runSession rootDir session = do
                                           def
                                           (Just TraceOff)
 
                                           def
                                           (Just TraceOff)
 

-  runSessionWithHandler listenServer rootDir $ do
+  runSessionWithHandler listenServer serverExe rootDir $ do

 
     -- Wrap the session around initialize and shutdown calls
 
     -- Wrap the session around initialize and shutdown calls

-    sendRequest (Proxy :: Proxy InitializeRequest) Initialize initializeParams
-    RspInitialize initRsp <- response
-    liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRsp ^. LSP.error)
+    sendRequest Initialize initializeParams
+    initRspMsg <- response :: Session InitializeResponse
+
+    liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
+
+    initRspVar <- initRsp <$> ask
+    liftIO $ putMVar initRspVar initRspMsg
+    

 
     sendNotification Initialized InitializedParams
 
 
     sendNotification Initialized InitializedParams
 


@@ -120,15 +119,15 @@ runSession rootDir session = do
 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
 -- It also does not automatically send initialize and exit messages.
 runSessionWithHandler :: (Handle -> Session ())
 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
 -- It also does not automatically send initialize and exit messages.
 runSessionWithHandler :: (Handle -> Session ())

+                      -> String

                       -> FilePath
                       -> Session a
                       -> IO a
                       -> FilePath
                       -> Session a
                       -> IO a

-runSessionWithHandler serverHandler rootDir session = do
+runSessionWithHandler serverHandler serverExe rootDir session = do

   absRootDir <- canonicalizePath rootDir
 
   absRootDir <- canonicalizePath rootDir
 

-  (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess
-    (proc "hie" ["--lsp", "-d", "-l", "/tmp/hie-test.log"])
-    { std_in = CreatePipe, std_out = CreatePipe }
+  let createProc = (shell serverExe) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }
+  (Just serverIn, Just serverOut, _, serverProc) <- createProcess createProc

 
   hSetBuffering serverIn  NoBuffering
   hSetBuffering serverOut NoBuffering
 
   hSetBuffering serverIn  NoBuffering
   hSetBuffering serverOut NoBuffering


@@ -136,14 +135,16 @@ runSessionWithHandler serverHandler rootDir session = do
   reqMap <- newMVar newRequestMap
   messageChan <- newChan
   meaninglessChan <- newChan
   reqMap <- newMVar newRequestMap
   messageChan <- newChan
   meaninglessChan <- newChan

+  initRsp <- newEmptyMVar

 
 

-  let context = SessionContext serverIn absRootDir messageChan reqMap
+  let context = SessionContext serverIn absRootDir messageChan reqMap initRsp

       initState = SessionState (IdInt 9)
 
       initState = SessionState (IdInt 9)
 

-  forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
+  threadId <- forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)

   (result, _) <- runSession' messageChan context initState session
 
   terminateProcess serverProc
   (result, _) <- runSession' messageChan context initState session
 
   terminateProcess serverProc

+  killThread threadId

 
   return result
 
 
   return result
 


@@ -168,29 +169,45 @@ listenServer serverOut = do
 --             (DocumentSymbolParams docId)
 -- @
 sendRequest
 --             (DocumentSymbolParams docId)
 -- @
 sendRequest

-  :: forall params resp. (ToJSON params, ToJSON resp, FromJSON resp)
-  => Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
-  -> ClientMethod -- ^ The request method.
+  :: (ToJSON params)
+  => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request.
+  ClientMethod -- ^ The request method.

   -> params -- ^ The request parameters.
   -> Session LspId -- ^ The id of the request that was sent.
   -> params -- ^ The request parameters.
   -> Session LspId -- ^ The id of the request that was sent.

-sendRequest _ method params = do
+sendRequest method params = do

   id <- curReqId <$> get
   modify $ \c -> c { curReqId = nextId id }
 
   id <- curReqId <$> get
   modify $ \c -> c { curReqId = nextId id }
 

-  let req = RequestMessage "2.0" id method params :: RequestMessage ClientMethod params resp
+  let req = RequestMessage' "2.0" id method params

 
 

-  sendRequest' req
+  -- Update the request map
+  reqMap <- requestMap <$> ask
+  liftIO $ modifyMVar_ reqMap $
+    \r -> return $ updateRequestMap r id method
+
+  sendMessage req

 
   return id
 
   where nextId (IdInt i) = IdInt (i + 1)
         nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
 
 
   return id
 
   where nextId (IdInt i) = IdInt (i + 1)
         nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
 

+-- | A custom type for request message that doesn't
+-- need a response type, allows us to infer the request
+-- message type without using proxies.
+data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
+
+instance ToJSON a => ToJSON (RequestMessage' a) where
+  toJSON (RequestMessage' rpc id method params) =
+    object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
+
+

 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 sendRequest' req = do
   -- Update the request map
   reqMap <- requestMap <$> ask
 sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
 sendRequest' req = do
   -- Update the request map
   reqMap <- requestMap <$> ask

-  liftIO $ modifyMVar_ reqMap (return . flip updateRequestMap req)
+  liftIO $ modifyMVar_ reqMap $
+    \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)

 
   sendMessage req
 
 
   sendMessage req
 


@@ -214,6 +231,12 @@ sendMessage msg = do
   h <- serverIn <$> ask
   liftIO $ B.hPut h $ addHeader (encode msg)
 
   h <- serverIn <$> ask
   liftIO $ B.hPut h $ addHeader (encode msg)
 

+-- | Returns the initialize response that was received from the server.
+-- The initialize requests and responses are not included the session,
+-- so if you need to test it use this.
+getInitializeResponse :: Session InitializeResponse
+getInitializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
+

 -- | Opens a text document and sends a notification to the client.
 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 openDoc file languageId = do
 -- | Opens a text document and sends a notification to the client.
 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 openDoc file languageId = do