X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FReplay.hs;h=979b789149262c6947e195c58122310ef8a6d5cc;hb=e2ae28cd825653b0cb8b982d113497e9ac795059;hp=1e361542b71f39b1356491b2232f1f119e072165;hpb=0f8b9d328f4d950ff0a2e1c3b5aed593b21c2d3a;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs
index 1e36154..979b789 100644
--- a/src/Language/Haskell/LSP/Test/Replay.hs
+++ b/src/Language/Haskell/LSP/Test/Replay.hs
@@ -7,7 +7,6 @@ where
 
 import           Prelude hiding (id)
 import           Control.Concurrent
-import           Control.Exception
 import           Control.Monad.IO.Class
 import qualified Data.ByteString.Lazy.Char8    as B
 import qualified Data.Text                     as T
@@ -20,7 +19,6 @@ import           Data.List
 import           Data.Maybe
 import           Control.Lens hiding (List)
 import           Control.Monad
-import           System.IO
 import           System.FilePath
 import           Language.Haskell.LSP.Test
 import           Language.Haskell.LSP.Test.Files
@@ -35,7 +33,7 @@ import           Language.Haskell.LSP.Test.Server
 -- named "session.log".
 replaySession :: String -- ^ The command to run the server.
               -> FilePath -- ^ The recorded session directory.
-              -> IO Bool
+              -> IO ()
 replaySession serverExe sessionDir = do
 
   entries <- B.lines <$> B.readFile (sessionDir </> "session.log")
@@ -43,7 +41,7 @@ replaySession serverExe sessionDir = do
   -- decode session
   let unswappedEvents = map (fromJust . decode) entries
 
-  withServer serverExe $ \serverIn serverOut pid -> do
+  withServer serverExe False $ \serverIn serverOut pid -> do
 
     events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents
 
@@ -55,19 +53,18 @@ replaySession serverExe sessionDir = do
 
     reqSema <- newEmptyMVar
     rspSema <- newEmptyMVar
-    passVar <- newEmptyMVar :: IO (MVar Bool)
+    passSema <- newEmptyMVar
+    mainThread <- myThreadId
 
-    threadId <- forkIO $
+    sessionThread <- liftIO $ forkIO $
       runSessionWithHandles serverIn
                             serverOut
-                            (listenServer serverMsgs requestMap reqSema rspSema passVar)
+                            (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread)
                             def
                             sessionDir
                             (sendMessages clientMsgs reqSema rspSema)
-
-    result <- takeMVar passVar
-    killThread threadId
-    return result
+    takeMVar passSema
+    killThread sessionThread
 
   where
     isClientMsg (FromClient _ _) = True
@@ -97,7 +94,7 @@ sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
     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
@@ -125,51 +122,51 @@ isNotification (NotShowMessage             _) = True
 isNotification (NotCancelRequestFromServer _) = True
 isNotification _                              = False
 
-listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar Bool -> Handle -> Session ()
-listenServer [] _ _ _ passVar _ = liftIO $ putMVar passVar True
-listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut  = do
-
-  let handler :: IOException -> IO B.ByteString
-      handler _ = putMVar passVar False >> return B.empty
-
-  msgBytes <- liftIO $ catch (getNextMessage serverOut) handler
+-- 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 <- getNextMessage serverOut
   let msg = decodeFromServerMsg reqMap msgBytes
 
   handleServerMessage request response notification msg
 
   if shouldSkip msg
-    then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut
+    then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx
     else if inRightOrder msg expectedMsgs
-      then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut
-      else liftIO $ do
-        putStrLn "Out of order"
-        putStrLn "Got:"
-        print msg
-        putStrLn "Expected one of:"
-        mapM_ print $ takeWhile (not . isNotification) expectedMsgs
-        print $ head $ dropWhile isNotification expectedMsgs
-        putMVar passVar False
+      then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx
+      else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs
+                ++ [head $ dropWhile isNotification expectedMsgs]
+               exc = ReplayOutOfOrder msg remainingMsgs
+            in liftIO $ throwTo mainThreadId exc
 
   where
-  response :: ResponseMessage a -> Session ()
+  response :: ResponseMessage a -> IO ()
   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
-    liftIO
-      $  putStrLn
+    putStrLn
       $  "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)