X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=17a39c5a9702a9e2146514c65165220270ff516f;hb=edee40c4aba2607c652cace2da780c373612665f;hp=087143fa8960537db6d71dab2c3bc70e82e83221;hpb=4eb97ef8a3d4b3908fa9b5bbbd5ae77cfa95cecc;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index 087143f..17a39c5 100644
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -24,8 +24,11 @@ module Language.Haskell.LSP.Test
   , sendNotification'
   , sendResponse
   -- * Receving
+  , anyRequest
   , request
+  , anyResponse
   , response
+  , anyNotification
   , notification
   , loggingNotification
   , publishDiagnosticsNotification
@@ -61,17 +64,15 @@ import Control.Applicative.Combinators
 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 Data.Proxy
 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
@@ -80,7 +81,7 @@ import Language.Haskell.LSP.Test.Decoding
 import Language.Haskell.LSP.Test.Parsing
 
 -- | Starts a new session.
-runSession :: FilePath -- ^ The filepath to the server executable.
+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 ()
@@ -98,8 +99,8 @@ runSession serverExe rootDir session = do
   runSessionWithHandler listenServer serverExe rootDir $ do
 
     -- 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
@@ -112,16 +113,15 @@ runSession serverExe 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 ())
-                      -> FilePath
+                      -> String
                       -> FilePath
                       -> Session a
                       -> IO a
 runSessionWithHandler serverHandler serverExe rootDir session = do
   absRootDir <- canonicalizePath rootDir
 
-  (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess
-    (proc serverExe ["--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
@@ -133,10 +133,11 @@ runSessionWithHandler serverHandler serverExe rootDir session = do
   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
+  killThread threadId
 
   return result
 
@@ -161,29 +162,45 @@ listenServer serverOut = do
 --             (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.
-sendRequest _ method params = do
+sendRequest method params = do
   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
+
+  -- Update the request map
+  reqMap <- requestMap <$> ask
+  liftIO $ modifyMVar_ reqMap $
+    \r -> return $ updateRequestMap r id method
 
-  sendRequest' req
+  sendMessage req
 
   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
-  liftIO $ modifyMVar_ reqMap (return . flip updateRequestMap req)
+  liftIO $ modifyMVar_ reqMap $
+    \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
 
   sendMessage req