Don't use exitServer in Replay

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

diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs
index ad26858ee39632d4a5e8260a83576ef0a65a93b6..ac55e9e749008c575f8a5c50dafbbec70b15040d 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Replay.hs
+++ b/src/Language/Haskell/LSP/Test/Replay.hs
@@ -12,21 +12,23 @@ import qualified Data.ByteString.Lazy.Char8    as B
 import qualified Data.Text                     as T
 import           Language.Haskell.LSP.Capture
 import           Language.Haskell.LSP.Messages
 import qualified Data.Text                     as T
 import           Language.Haskell.LSP.Capture
 import           Language.Haskell.LSP.Messages

-import           Language.Haskell.LSP.Types as LSP hiding (error)
+import           Language.Haskell.LSP.Types
+import           Language.Haskell.LSP.Types.Lens as LSP hiding (error)

 import           Data.Aeson
 import           Data.Default
 import           Data.List
 import           Data.Maybe
 import           Control.Lens hiding (List)
 import           Control.Monad
 import           Data.Aeson
 import           Data.Default
 import           Data.List
 import           Data.Maybe
 import           Control.Lens hiding (List)
 import           Control.Monad

-import           System.IO

 import           System.FilePath
 import           System.FilePath

+import           System.IO

 import           Language.Haskell.LSP.Test
 import           Language.Haskell.LSP.Test

+import           Language.Haskell.LSP.Test.Compat

 import           Language.Haskell.LSP.Test.Files
 import           Language.Haskell.LSP.Test.Decoding
 import           Language.Haskell.LSP.Test.Messages
 import           Language.Haskell.LSP.Test.Server
 import           Language.Haskell.LSP.Test.Files
 import           Language.Haskell.LSP.Test.Decoding
 import           Language.Haskell.LSP.Test.Messages
 import           Language.Haskell.LSP.Test.Server

-
+import           Language.Haskell.LSP.Test.Session

 
 -- | Replays a captured client output and
 -- makes sure it matches up with an expected response.
 
 -- | Replays a captured client output and
 -- makes sure it matches up with an expected response.


@@ -42,8 +44,9 @@ replaySession serverExe sessionDir = do
   -- decode session
   let unswappedEvents = map (fromJust . decode) entries
 
   -- decode session
   let unswappedEvents = map (fromJust . decode) entries
 

-  withServer serverExe $ \serverIn serverOut pid -> do
+  withServer serverExe False $ \serverIn serverOut serverProc -> do

 
 

+    pid <- getProcessID serverProc

     events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents
 
     let clientEvents = filter isClientMsg events
     events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents
 
     let clientEvents = filter isClientMsg events


@@ -58,11 +61,12 @@ replaySession serverExe sessionDir = do
     mainThread <- myThreadId
 
     sessionThread <- liftIO $ forkIO $
     mainThread <- myThreadId
 
     sessionThread <- liftIO $ forkIO $

-      runSessionWithHandles serverIn
-                            serverOut
+      runSessionWithHandles serverIn serverOut serverProc

                             (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread)
                             def
                             (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread)
                             def

+                            fullCaps

                             sessionDir
                             sessionDir

+                            (return ()) -- No finalizer cleanup

                             (sendMessages clientMsgs reqSema rspSema)
     takeMVar passSema
     killThread sessionThread
                             (sendMessages clientMsgs reqSema rspSema)
     takeMVar passSema
     killThread sessionThread


@@ -83,19 +87,19 @@ sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
   notification msg@(NotificationMessage _ Exit _) = do
     liftIO $ putStrLn "Will send exit notification soon"
     liftIO $ threadDelay 10000000
   notification msg@(NotificationMessage _ Exit _) = do
     liftIO $ putStrLn "Will send exit notification soon"
     liftIO $ threadDelay 10000000

-    sendNotification' msg
+    sendMessage msg

 
     liftIO $ error "Done"
 
   notification msg@(NotificationMessage _ m _) = do
 
     liftIO $ error "Done"
 
   notification msg@(NotificationMessage _ m _) = do

-    sendNotification' msg
+    sendMessage msg

 
     liftIO $ putStrLn $ "Sent a notification " ++ show m
 
     sendMessages remainingMsgs reqSema rspSema
 
   request msg@(RequestMessage _ id m _) = do
 
     liftIO $ putStrLn $ "Sent a notification " ++ show m
 
     sendMessages remainingMsgs reqSema rspSema
 
   request msg@(RequestMessage _ id m _) = do

-    sendRequest' msg
+    sendRequestMessage msg

     liftIO $ putStrLn $  "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
 
     rsp <- liftIO $ takeMVar rspSema
     liftIO $ putStrLn $  "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
 
     rsp <- liftIO $ takeMVar rspSema


@@ -115,6 +119,15 @@ sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
 
     sendMessages remainingMsgs reqSema rspSema
 
 
     sendMessages remainingMsgs reqSema rspSema
 

+sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
+sendRequestMessage req = do
+  -- Update the request map
+  reqMap <- requestMap <$> ask
+  liftIO $ modifyMVar_ reqMap $
+    \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
+
+  sendMessage req
+

 
 isNotification :: FromServerMessage -> Bool
 isNotification (NotPublishDiagnostics      _) = True
 
 isNotification :: FromServerMessage -> Bool
 isNotification (NotPublishDiagnostics      _) = True


@@ -123,44 +136,51 @@ isNotification (NotShowMessage             _) = True
 isNotification (NotCancelRequestFromServer _) = True
 isNotification _                              = False
 
 isNotification (NotCancelRequestFromServer _) = True
 isNotification _                              = False
 

-listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar () -> ThreadId -> Handle -> Session ()
-listenServer [] _ _ _ passSema _ _ = liftIO $ putMVar passSema ()
-listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut  = do
+listenServer :: [FromServerMessage]
+             -> RequestMap
+             -> MVar LspId
+             -> MVar LspIdRsp
+             -> MVar ()
+             -> ThreadId
+             -> Handle
+             -> SessionContext
+             -> IO ()
+listenServer [] _ _ _ passSema _ _ _ = putMVar passSema ()
+listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx = do

 
 

-  msgBytes <- liftIO $ getNextMessage serverOut
+  msgBytes <- getNextMessage serverOut

   let msg = decodeFromServerMsg reqMap msgBytes
 
   handleServerMessage request response notification msg
 
   if shouldSkip msg
   let msg = decodeFromServerMsg reqMap msgBytes
 
   handleServerMessage request response notification msg
 
   if shouldSkip msg

-    then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut
+    then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx

     else if inRightOrder msg expectedMsgs
     else if inRightOrder msg expectedMsgs

-      then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut
-      else let expectedMsgs = takeWhile (not . isNotification) expectedMsgs
+      then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx
+      else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs

                 ++ [head $ dropWhile isNotification expectedMsgs]
                 ++ [head $ dropWhile isNotification expectedMsgs]

-               exc = ReplayOutOfOrderException msg expectedMsgs
+               exc = ReplayOutOfOrder msg remainingMsgs

             in liftIO $ throwTo mainThreadId exc
 
   where
             in liftIO $ throwTo mainThreadId exc
 
   where

-  response :: ResponseMessage a -> Session ()
+  response :: ResponseMessage a -> IO ()

   response res = do
   response res = do

-    liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id)
+    putStrLn $ "Got response for id " ++ show (res ^. id)

 
 

-    liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
+    putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request

 
 

-  request :: RequestMessage ServerMethod a b -> Session ()
+  request :: RequestMessage ServerMethod a b -> IO ()

   request req = do
   request req = do

-    liftIO
-      $  putStrLn
+    putStrLn

       $  "Got request for id "
       ++ show (req ^. id)
       ++ " "
       ++ show (req ^. method)
 
       $  "Got request for id "
       ++ show (req ^. id)
       ++ " "
       ++ show (req ^. method)
 

-    liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
+    putMVar reqSema (req ^. id) -- unblock the handler waiting for a response

 
 

-  notification :: NotificationMessage ServerMethod a -> Session ()
-  notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)
+  notification :: NotificationMessage ServerMethod a -> IO ()
+  notification n = putStrLn $ "Got notification " ++ show (n ^. method)