X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=79b7b1e7147934150d4cf632b9c142940e2191e0;hb=bc52b000bf018360efbfa0fcd289329c70d2c77e;hp=c16ae84f2a6a9864033246767f984ec2ae40fb37;hpb=7b99b44066a1fce5a5956452a1d658045631c8f9;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index c16ae84..79b7b1e 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
@@ -33,31 +36,21 @@ module Language.Haskell.LSP.Test
   , choice
   , option
   , optional
-  , skipOptional
   , between
   , some
   , many
   , sepBy
   , sepBy1
-  , sepByNonEmpty
   , sepEndBy1
-  , sepEndByNonEmpty
   , sepEndBy
   , endBy1
-  , endByNonEmpty
   , endBy
   , count
-  , chainl
-  , chainr
-  , chainl1
-  , chainr1
   , manyTill
-  , try
-  , (<?>)
   , skipMany
   , skipSome
-  , unexpected
-  , notFollowedBy
+  , skipManyTill
+  , skipSomeTill
   , (<|>)
   , satisfy
   -- * Utilities
@@ -67,33 +60,32 @@ module Language.Haskell.LSP.Test
   ) where
 
 import Control.Applicative
+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
 import System.FilePath
 import Language.Haskell.LSP.Test.Decoding
 import Language.Haskell.LSP.Test.Parsing
-import Text.Parser.Combinators
 
 -- | Starts a new session.
-runSession :: FilePath -- ^ The filepath to the root directory for the session.
+runSession :: FilePath -- ^ The filepath to the server executable.
+           -> FilePath -- ^ The filepath to the root directory for the session.
            -> Session a -- ^ The session to run.
            -> IO ()
-runSession rootDir session = do
+runSession serverExe rootDir session = do
   pid <- getProcessID
   absRootDir <- canonicalizePath rootDir
 
@@ -104,11 +96,11 @@ runSession rootDir session = do
                                           def
                                           (Just TraceOff)
 
-  runSessionWithHandler listenServer rootDir $ 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
@@ -121,14 +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 ())
+                      -> FilePath
                       -> FilePath
                       -> Session a
                       -> IO a
-runSessionWithHandler serverHandler rootDir session = do
+runSessionWithHandler serverHandler serverExe rootDir session = do
   absRootDir <- canonicalizePath rootDir
 
   (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess
-    (proc "hie" ["--lsp", "-d", "-l", "/tmp/hie-test.log"])
+    (proc serverExe ["--lsp", "-d", "-l", "/tmp/hie-test.log"])
     { std_in = CreatePipe, std_out = CreatePipe }
 
   hSetBuffering serverIn  NoBuffering
@@ -141,10 +134,11 @@ runSessionWithHandler serverHandler 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
 
@@ -169,29 +163,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