X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FReplay.hs;h=250fb2acb7537c783e01e4782853e059089bec51;hb=d8e460543b7cbc32550bed20d20ef4b13d6705a5;hp=2d5e4e612284ab6c3329a5aa7c36c548f45a1ef2;hpb=ac2553b38ed2228839cb72747f8c48b7c2fab488;p=opengl.git

diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs
index 2d5e4e6..250fb2a 100644
--- a/src/Language/Haskell/LSP/Test/Replay.hs
+++ b/src/Language/Haskell/LSP/Test/Replay.hs
@@ -9,13 +9,15 @@ import           Prelude hiding (id)
 import           Control.Concurrent
 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
+import           Control.Lens hiding (List)
 import           Control.Monad
 import           System.IO
 import           System.FilePath
@@ -23,22 +25,26 @@ 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
 
 
 -- | Replays a captured client output and 
 -- makes sure it matches up with an expected response.
 -- The session directory should have a captured session file in it
 -- named "session.log".
-replaySession :: FilePath -- ^ The recorded session directory.
-              -> IO Bool
-replaySession sessionDir = do
+replaySession :: String -- ^ The command to run the server.
+              -> FilePath -- ^ The recorded session directory.
+              -> IO ()
+replaySession serverExe sessionDir = do
 
   entries <- B.lines <$> B.readFile (sessionDir </> "session.log")
 
   -- decode session
   let unswappedEvents = map (fromJust . decode) entries
 
-  events <- swapFiles sessionDir unswappedEvents
+  withServer serverExe False $ \serverIn serverOut pid -> do
+
+    events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents
 
     let clientEvents = filter isClientMsg events
         serverEvents = filter isServerMsg events
@@ -48,16 +54,18 @@ replaySession sessionDir = do
 
     reqSema <- newEmptyMVar
     rspSema <- newEmptyMVar
-  passVar <- newEmptyMVar :: IO (MVar Bool)
-
-  threadId <- forkIO $
-    runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar)
+    passSema <- newEmptyMVar
+    mainThread <- myThreadId
+
+    sessionThread <- liftIO $ forkIO $
+      runSessionWithHandles serverIn
+                            serverOut
+                            (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
@@ -87,7 +95,7 @@ sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
     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,26 +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
+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
   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 ()
@@ -184,3 +189,27 @@ shouldSkip (NotLogMessage  _) = True
 shouldSkip (NotShowMessage _) = True
 shouldSkip (ReqShowMessage _) = True
 shouldSkip _                  = False
+
+-- | Swaps out any commands uniqued with process IDs to match the specified process ID
+swapCommands :: Int -> [Event] -> [Event]
+swapCommands _ [] = []
+
+swapCommands pid (FromClient t (ReqExecuteCommand req):xs) =  FromClient t (ReqExecuteCommand swapped):swapCommands pid xs
+  where swapped = params . command .~ newCmd $ req
+        newCmd = swapPid pid (req ^. params . command)
+
+swapCommands pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapCommands pid xs
+  where swapped = case newCommands of
+          Just cmds -> result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
+          Nothing -> rsp
+        oldCommands = rsp ^? result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands
+        newCommands = fmap (fmap (swapPid pid)) oldCommands
+
+swapCommands pid (x:xs) = x:swapCommands pid xs
+
+hasPid :: T.Text -> Bool
+hasPid = (>= 2) . T.length . T.filter (':' ==)
+swapPid :: Int -> T.Text -> T.Text
+swapPid pid t
+  | hasPid t = T.append (T.pack $ show pid) $ T.dropWhile (/= ':') t
+  | otherwise = t
\ No newline at end of file