X-Git-Url: https://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FRecorded.hs;h=504f3ff1f74fb68fd810d88fff1061c80abc7353;hb=0c8e8f8436125b79e91a51267ca581d2e352e702;hp=cf20c67a2deff652c80b36c70ef5e94756b2f933;hpb=93bbb70d531238c46a28eb356a68c3648b88082f;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test/Recorded.hs b/src/Language/Haskell/LSP/Test/Recorded.hs
index cf20c67..504f3ff 100644
--- a/src/Language/Haskell/LSP/Test/Recorded.hs
+++ b/src/Language/Haskell/LSP/Test/Recorded.hs
@@ -30,8 +30,9 @@ import           Language.Haskell.LSP.Test.Parsing
 replay
   :: FilePath -- ^ The client output to replay to the server.
   -> FilePath -- ^ The expected response from the server.
+  -> FilePath -- ^ The root directory of the project
   -> IO Bool
-replay cfp sfp = do
+replay cfp sfp curRootDir = do
 
   -- need to keep hold of current directory since haskell-lsp changes it
   prevDir <- getCurrentDirectory
@@ -56,14 +57,18 @@ replay cfp sfp = do
   null         <- openFile "/dev/null" WriteMode
 
 
-  (clientMsgs, fileMap) <- swapFiles emptyFileMap clientRecIn
+  unswappedClientMsgs <- getAllMessages clientRecIn
+
+  let recRootDir = rootDir unswappedClientMsgs
+
+  (clientMsgs, fileMap) <- swapFiles emptyFileMap recRootDir curRootDir unswappedClientMsgs
 
   tmpDir <- getTemporaryDirectory
-  (_, mappedClientRecIn) <- openTempFile tmpDir "clientRecInMapped"
+  (mappedClientRecFp, mappedClientRecIn) <- openTempFile tmpDir "clientRecInMapped"
   mapM_ (B.hPut mappedClientRecIn . addHeader) clientMsgs
   hSeek mappedClientRecIn AbsoluteSeek 0
 
-  (expectedMsgs, _) <- swapFiles fileMap serverRecIn
+  (expectedMsgs, _) <- swapFiles fileMap recRootDir curRootDir =<< getAllMessages serverRecIn
 
   -- listen to server
   forkIO $ runReaderT (listenServer expectedMsgs serverOut semas) didPass
@@ -87,6 +92,9 @@ replay cfp sfp = do
   -- restore directory
   setCurrentDirectory prevDir
 
+  -- cleanup temp files
+  removeFile mappedClientRecFp
+
   return result
 
 -- | The internal monad for tests that can fail or pass,
@@ -122,18 +130,7 @@ listenServer expectedMsgs h semas@(reqSema, rspSema) = do
   listenServer newExpectedMsgs h semas
 
 
-  where jsonEqual :: (FromJSON a, Eq a) => a -> B.ByteString -> Bool
-        jsonEqual x y = Just x == decode y
-
-        deleteFirstJson _ [] = []
-        deleteFirstJson msg (x:xs)
-          | jsonEqual msg x = xs
-          | otherwise = x:deleteFirstJson msg xs
-
-        -- firstExpected :: Show a => a
-        firstExpected = head $ filter (not . isNotification) expectedMsgs
-
-        response :: LSP.ResponseMessage Value -> Session [B.ByteString]
+  where response :: LSP.ResponseMessage Value -> Session [B.ByteString]
         response res = do
           lift $ putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
 
@@ -143,7 +140,7 @@ listenServer expectedMsgs h semas@(reqSema, rspSema) = do
 
           lift $ putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
 
-          return $ deleteFirstJson res expectedMsgs
+          markReceived res
 
         request :: LSP.RequestMessage LSP.ServerMethod Value Value -> Session [B.ByteString]
         request req = do
@@ -155,19 +152,38 @@ listenServer expectedMsgs h semas@(reqSema, rspSema) = do
 
           lift $ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
 
-          return $ deleteFirstJson req expectedMsgs
+          markReceived req
 
         notification :: LSP.NotificationMessage LSP.ServerMethod Value -> Session [B.ByteString]
         notification n = do
           lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
           lift $ print n
-          return $ deleteFirstJson n expectedMsgs
+
+          lift $ putStrLn $ show ((length $ filter isNotification expectedMsgs) - 1) ++ " notifications remaining"
+
+          if n ^. LSP.method == LSP.WindowLogMessage
+            then return expectedMsgs
+            else markReceived n
 
         checkOrder msg = unless (inRightOrder msg expectedMsgs) $ do
-          let expected = decode firstExpected
-              _ = expected == Just msg -- make expected type same as res
+          let (Just expected) = decode firstExpected
+              _ = expected == msg -- make expected type same as res
           failSession ("Out of order\nExpected\n" ++ show expected ++ "\nGot\n" ++ show msg ++ "\n")
 
+        markReceived msg =
+          let new = deleteFirstJson msg expectedMsgs
+           in if new == expectedMsgs
+              then failSession ("Unexpected message: " ++ show msg) >> return new
+              else return new
+
+        deleteFirstJson _ [] = []
+        deleteFirstJson msg (x:xs)
+          | Just msg == decode x = xs
+          | otherwise = x:deleteFirstJson msg xs
+
+        firstExpected = head $ filter (not . isNotification) expectedMsgs
+
+
 
 isNotification :: B.ByteString -> Bool
 isNotification msg =
@@ -235,10 +251,10 @@ handlers serverH (reqSema, rspSema) = def
  where
 
   -- TODO: May need to prevent premature exit notification being sent
-  -- notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
-  --   putStrLn "Will send exit notification soon"
-  --   threadDelay 10000000
-  --   B.hPut serverH $ addHeader (encode msg)
+  notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
+    putStrLn "Will send exit notification soon"
+    threadDelay 10000000
+    B.hPut serverH $ addHeader (encode msg)
   notification msg@(LSP.NotificationMessage _ m _) = do
     B.hPut serverH $ addHeader (encode msg)