From: Luke Lau Date: Thu, 21 Jun 2018 12:53:19 +0000 (+0100) Subject: Add ReplayOutOfOrder exception and change function signature X-Git-Url: http://git.lukelau.me/?p=opengl.git;a=commitdiff_plain;h=bd6901688e6c9d8332fea161260d32666885f9ed Add ReplayOutOfOrder exception and change function signature --- diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal index c593f6e..42171da 100644 --- 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 a25c802..e9c65f9 100644 --- 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 1e36154..ad26858 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 @@ -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/test/Test.hs b/test/Test.hs index c8d6072..3c53aec 100644 --- a/test/Test.hs +++ b/test/Test.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" $