Change server filepath to a command to run

[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..086a34c9257465d8ef284f66e5138486dbc91832 100644 (file)
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -24,39 +24,33 @@ 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


@@ -66,33 +60,32 @@ module Language.Haskell.LSP.Test
   ) where
 
 import Control.Applicative
   ) 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,11 +96,11 @@ 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
+    sendRequest Initialize initializeParams
+    initRsp <- response :: Session InitializeResponse

     liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRsp ^. LSP.error)
 
     sendNotification Initialized InitializedParams
     liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRsp ^. LSP.error)
 
     sendNotification Initialized InitializedParams


@@ -120,15 +113,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 }
+  (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess createProc

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


@@ -140,10 +133,11 @@ runSessionWithHandler serverHandler rootDir session = do
   let context = SessionContext serverIn absRootDir messageChan reqMap
       initState = SessionState (IdInt 9)
 
   let context = SessionContext serverIn absRootDir messageChan reqMap
       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 +162,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