Update command uniquing to match hie

[opengl.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 4802c9ad152afb7b57d8a2a7d906d81b99a459a8..0be0c54d3736d4e90d920271af8125a4107f327b 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Replay.hs
+++ b/src/Language/Haskell/LSP/Test/Replay.hs
@@ -7,15 +7,17 @@ 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
 import           Language.Haskell.LSP.Capture
 import           Language.Haskell.LSP.Messages
 import           Language.Haskell.LSP.Types hiding (error)
 import           Data.Aeson
 import           Data.List
 import           Data.Maybe
-import           Control.Lens
+import           Control.Lens hiding (List)
 import           Control.Monad
 import           System.IO
 import           System.FilePath
@@ -23,13 +25,14 @@ 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 filepath to the server executable.
+replaySession :: String -- ^ The command to run the server.
               -> FilePath -- ^ The recorded session directory.
               -> IO Bool
 replaySession serverExe sessionDir = do
@@ -39,7 +42,9 @@ replaySession serverExe sessionDir = do
   -- decode session
   let unswappedEvents = map (fromJust . decode) entries
 
-  events <- swapFiles sessionDir unswappedEvents
+  withServer serverExe $ \serverIn serverOut pid -> do
+
+    events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents
 
     let clientEvents = filter isClientMsg events
         serverEvents = filter isServerMsg events
@@ -51,10 +56,16 @@ replaySession serverExe sessionDir = do
     rspSema <- newEmptyMVar
     passVar <- newEmptyMVar :: IO (MVar Bool)
 
-  forkIO $ runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar) serverExe sessionDir $
-    sendMessages clientMsgs reqSema rspSema
+    threadId <- forkIO $
+      runSessionWithHandles serverIn
+                            serverOut
+                            (listenServer serverMsgs requestMap reqSema rspSema passVar)
+                            sessionDir
+                            (sendMessages clientMsgs reqSema rspSema)
 
-  takeMVar passVar
+    result <- takeMVar passVar
+    killThread threadId
+    return result
 
   where
     isClientMsg (FromClient _ _) = True
@@ -115,7 +126,11 @@ 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
-  msgBytes <- liftIO $ getNextMessage serverOut
+
+  let handler :: IOException -> IO B.ByteString
+      handler _ = putMVar passVar False >> return B.empty
+
+  msgBytes <- liftIO $ catch (getNextMessage serverOut) handler
   let msg = decodeFromServerMsg reqMap msgBytes
 
   handleServerMessage request response notification msg
@@ -181,3 +196,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 . capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
+          Nothing -> rsp
+        oldCommands = rsp ^? result . _Just . 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