X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FReplay.hs;h=45de1593305c6611842af677983e2555b5eebfef;hb=4ade7ffa7ba14d0087121bc8c4255e130e343dfb;hp=b224be6cbf0132a6e50b6bc0380edd453ac94e2d;hpb=fe5448266f5db772dd3f10be432cd56581bbcb40;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs index b224be6..45de159 100644 --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@ -12,7 +12,8 @@ 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 as LSP hiding (error) +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Lens as LSP import Data.Aeson import Data.Default import Data.List @@ -20,17 +21,21 @@ import Data.Maybe import Control.Lens hiding (List) import Control.Monad import System.FilePath +import System.IO import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Test.Compat 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 -- makes sure it matches up with an expected response. -- The session directory should have a captured session file in it -- named "session.log". +-- You can get these capture files from 'Language.Haskell.LSP.resCaptureFile' in +-- haskell-lsp. replaySession :: String -- ^ The command to run the server. -> FilePath -- ^ The recorded session directory. -> IO () @@ -41,8 +46,9 @@ replaySession serverExe sessionDir = do -- decode session let unswappedEvents = map (fromJust . decode) entries - withServer serverExe False $ \serverIn serverOut pid -> do + withServer serverExe False $ \serverIn serverOut serverProc -> do + pid <- getProcessID serverProc events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents let clientEvents = filter isClientMsg events @@ -57,11 +63,12 @@ replaySession serverExe sessionDir = do mainThread <- myThreadId sessionThread <- liftIO $ forkIO $ - runSessionWithHandles serverIn - serverOut + runSessionWithHandles serverIn serverOut serverProc (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread) def + fullCaps sessionDir + (return ()) -- No finalizer cleanup (sendMessages clientMsgs reqSema rspSema) takeMVar passSema killThread sessionThread @@ -82,12 +89,12 @@ 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 @@ -103,7 +110,7 @@ sendMessages (nextMsg:remainingMsgs) reqSema rspSema = sendMessages remainingMsgs reqSema rspSema - response msg@(ResponseMessage _ id _ _) = do + response msg@(ResponseMessage _ id _) = do liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server" reqId <- liftIO $ takeMVar reqSema if responseId reqId /= id @@ -114,6 +121,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 @@ -122,15 +138,15 @@ isNotification (NotShowMessage _) = True isNotification (NotCancelRequestFromServer _) = True isNotification _ = False --- listenServer :: [FromServerMessage] --- -> RequestMap --- -> MVar LspId --- -> MVar LspIdRsp --- -> MVar () --- -> ThreadId --- -> Handle --- -> SessionContext --- -> IO () +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 @@ -145,7 +161,7 @@ listenServer 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 @@ -206,9 +222,9 @@ swapCommands pid (FromClient t (ReqExecuteCommand req):xs) = FromClient t (ReqE 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 + Just cmds -> result . _Right . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp Nothing -> rsp - oldCommands = rsp ^? result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands + oldCommands = rsp ^? result . _Right . LSP.capabilities . executeCommandProvider . _Just . commands newCommands = fmap (fmap (swapPid pid)) oldCommands swapCommands pid (x:xs) = x:swapCommands pid xs