Hide some internals

[lsp-test.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 88bc09228fd3a76e643fcc01ab62e692d0ac3f1d..6c049d0b56272fd9ff7ff7992ef02370cccdbaa7 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Replay.hs
+++ b/src/Language/Haskell/LSP/Test/Replay.hs
@@ -19,13 +19,13 @@ 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
 import           Language.Haskell.LSP.Test.Decoding
 import           Language.Haskell.LSP.Test.Messages
 import           Language.Haskell.LSP.Test.Server
+import           Language.Haskell.LSP.Test.Session
 
 
 -- | Replays a captured client output and 
@@ -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
 
@@ -62,6 +62,7 @@ replaySession serverExe sessionDir = do
                             serverOut
                             (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread)
                             def
+                            fullCaps
                             sessionDir
                             (sendMessages clientMsgs reqSema rspSema)
     takeMVar passSema
@@ -83,19 +84,19 @@ sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
   notification msg@(NotificationMessage _ Exit _) = do
     liftIO $ putStrLn "Will send exit notification soon"
     liftIO $ threadDelay 10000000
-    sendNotification' msg
+    sendMessage msg
 
     liftIO $ error "Done"
 
   notification msg@(NotificationMessage _ m _) = do
-    sendNotification' msg
+    sendMessage msg
 
     liftIO $ putStrLn $ "Sent a notification " ++ show m
 
     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
@@ -115,6 +116,15 @@ sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
 
     sendMessages remainingMsgs reqSema rspSema
 
+sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
+sendRequestMessage req = do
+  -- Update the request map
+  reqMap <- requestMap <$> ask
+  liftIO $ modifyMVar_ reqMap $
+    \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
+
+  sendMessage req
+
 
 isNotification :: FromServerMessage -> Bool
 isNotification (NotPublishDiagnostics      _) = True
@@ -123,44 +133,51 @@ isNotification (NotShowMessage             _) = True
 isNotification (NotCancelRequestFromServer _) = True
 isNotification _                              = False
 
-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 $ getNextMessage serverOut
+-- 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 passSema mainThreadId serverOut
+    then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx
     else if inRightOrder msg expectedMsgs
-      then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut
+      then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx
       else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs
                 ++ [head $ dropWhile isNotification expectedMsgs]
-               exc = ReplayOutOfOrderException msg remainingMsgs
+               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)