Add config option to log stderr

[opengl.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 0be0c54d3736d4e90d920271af8125a4107f327b..68e6b1ba56424fe4f846fb111b3130717fe6ba4f 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Replay.hs
+++ b/src/Language/Haskell/LSP/Test/Replay.hs
@@ -7,14 +7,14 @@ 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
 import           Language.Haskell.LSP.Capture
 import           Language.Haskell.LSP.Messages
-import           Language.Haskell.LSP.Types hiding (error)
+import           Language.Haskell.LSP.Types as LSP hiding (error)
 import           Data.Aeson
+import           Data.Default
 import           Data.List
 import           Data.Maybe
 import           Control.Lens hiding (List)
@@ -34,7 +34,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")
@@ -42,7 +42,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
 
@@ -54,18 +54,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
@@ -123,30 +123,23 @@ 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
+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
 
-  msgBytes <- liftIO $ catch (getNextMessage serverOut) handler
+  msgBytes <- liftIO $ 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
     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
+      else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs
+                ++ [head $ dropWhile isNotification expectedMsgs]
+               exc = ReplayOutOfOrderException msg remainingMsgs
+            in liftIO $ throwTo mainThreadId exc
 
   where
   response :: ResponseMessage a -> Session ()
@@ -207,9 +200,9 @@ swapCommands pid (FromClient t (ReqExecuteCommand req):xs) =  FromClient t (ReqE
 
 swapCommands pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapCommands pid xs
   where swapped = case newCommands of
-          Just cmds -> result . _Just . capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
+          Just cmds -> result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
           Nothing -> rsp
-        oldCommands = rsp ^? result . _Just . capabilities . executeCommandProvider . _Just . commands
+        oldCommands = rsp ^? result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands
         newCommands = fmap (fmap (swapPid pid)) oldCommands
 
 swapCommands pid (x:xs) = x:swapCommands pid xs