Add ReplayOutOfOrder exception and change function signature

diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal
index c593f6e1a2f634bee5fbbe341bd0377e8578e2d9..42171da1de244bd79c1ca1312cd1ce3fe003719c 100644 (file)
--- a/haskell-lsp-test.cabal
+++ b/haskell-lsp-test.cabal
@@ -22,6 +22,7 @@ library
                      , haskell-lsp-types
                      , haskell-lsp >= 0.3
                      , aeson
+                     , async
                      , bytestring
                      , conduit
                      , conduit-parse

diff --git a/src/Language/Haskell/LSP/Test/Exceptions.hs b/src/Language/Haskell/LSP/Test/Exceptions.hs
index a25c802d5bcfd3750f03f2d46c8bad5412aea353..e9c65f9598711b89963884e5207488e471655548 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Exceptions.hs
+++ b/src/Language/Haskell/LSP/Test/Exceptions.hs
@@ -5,6 +5,7 @@ import Language.Haskell.LSP.Messages
 
 data SessionException = TimeoutException
                       | UnexpectedMessageException String FromServerMessage
+                      | ReplayOutOfOrderException FromServerMessage [FromServerMessage]
 
 instance Exception SessionException
 
@@ -14,6 +15,10 @@ instance Show SessionException where
     "Received an unexpected message from the server:\n" ++
     "Expected: " ++ expected ++ "\n" ++
     "Last message accepted: " ++ show lastMsg
+  show (ReplayOutOfOrderException received expected) =
+    "Replay is out of order:\n" ++
+    "Received from server:" ++ show received ++ "\n" ++
+    "Expected one of: " ++ concatMap show expected
 
 anySessionException :: SessionException -> Bool
 anySessionException = const True
\ No newline at end of file

diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs
index 1e361542b71f39b1356491b2232f1f119e072165..ad26858ee39632d4a5e8260a83576ef0a65a93b6 100644 (file)
--- 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
@@ -35,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")
@@ -55,19 +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
@@ -125,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 expectedMsgs = takeWhile (not . isNotification) expectedMsgs
+                ++ [head $ dropWhile isNotification expectedMsgs]
+               exc = ReplayOutOfOrderException msg expectedMsgs
+            in liftIO $ throwTo mainThreadId exc
 
   where
   response :: ResponseMessage a -> Session ()

diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs
index c8d6072f6ec386a88185937e2091dbaac12ab32d..3c53aec67dd292859abc0285e939da6d3d3d532f 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Session.hs
+++ b/src/Language/Haskell/LSP/Test/Session.hs
@@ -64,31 +64,35 @@ main = hspec $ do
                 return ()
         in sesh `shouldThrow` anySessionException
 
-      it "don't throw when no time out" $ runSessionWithConfig (def {timeout = 10}) "hie --lsp" "test/data/renamePass" $ do
+      it "don't throw when no time out" $ runSessionWithConfig (def {timeout = 5}) "hie --lsp" "test/data/renamePass" $ do
         loggingNotification
-        liftIO $ threadDelay 5
+        liftIO $ threadDelay 10
+        _ <- openDoc "Desktop/simple.hs" "haskell"
+        return ()
 
       it "throw when there's an unexpected message" $
-        let msgExc (UnexpectedMessageException "Publish diagnostics notification" (NotLogMessage _)) = True
-            msgExc _ = False
-          in runSession "hie --lsp" "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` msgExc
+        let selector (UnexpectedMessageException "Publish diagnostics notification" (NotLogMessage _)) = True
+            selector _ = False
+          in runSession "hie --lsp" "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
 
       it "throw when there's an unexpected message 2" $
-        let msgExc (UnexpectedMessageException "Response" (NotPublishDiagnostics _)) = True
-            msgExc _ = False
+        let selector (UnexpectedMessageException "Response" (NotPublishDiagnostics _)) = True
+            selector _ = False
             sesh = do
               doc <- openDoc "Desktop/simple.hs" "haskell"
               sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
               skipMany anyNotification
               response :: Session RenameResponse -- the wrong type
           in runSession "hie --lsp" "test/data/renamePass" sesh
-            `shouldThrow` msgExc
+            `shouldThrow` selector
 
   describe "replay session" $ do
     it "passes a test" $
-      replaySession "hie --lsp" "test/data/renamePass" `shouldReturn` True
+      replaySession "hie --lsp" "test/data/renamePass"
     it "fails a test" $
-      replaySession "hie --lsp" "test/data/renameFail" `shouldReturn` False
+      let selector (ReplayOutOfOrderException _ _) = True
+          selector _ = False
+        in replaySession "hie --lsp" "test/data/renameFail" `shouldThrow` selector
 
   describe "manual javascript session" $
     it "passes a test" $

diff --cc test/Test.hs
Simple merge