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

diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs
index c9507b5..2d5e4e6 100644
--- a/src/Language/Haskell/LSP/Test/Replay.hs
+++ b/src/Language/Haskell/LSP/Test/Replay.hs
@@ -1,6 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RankNTypes #-}
 -- | A testing tool for replaying captured client logs back to a server,
 -- and validating that the server output matches up with another log.
 module Language.Haskell.LSP.Test.Replay
@@ -24,7 +21,8 @@ import           System.IO
 import           System.FilePath
 import           Language.Haskell.LSP.Test
 import           Language.Haskell.LSP.Test.Files
-import           Language.Haskell.LSP.Test.Parsing
+import           Language.Haskell.LSP.Test.Decoding
+import           Language.Haskell.LSP.Test.Messages
 
 
 -- | Replays a captured client output and 
@@ -48,15 +46,18 @@ replaySession sessionDir = do
       serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents
       requestMap = getRequestMap clientMsgs
 
-
   reqSema <- newEmptyMVar
   rspSema <- newEmptyMVar
   passVar <- newEmptyMVar :: IO (MVar Bool)
 
-  forkIO $ runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar) sessionDir $
-    sendMessages clientMsgs reqSema rspSema
+  threadId <- forkIO $
+    runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar)
+                          sessionDir
+                          (sendMessages clientMsgs reqSema rspSema)
 
-  takeMVar passVar
+  result <- takeMVar passVar
+  killThread threadId
+  return result
 
   where
     isClientMsg (FromClient _ _) = True
@@ -68,42 +69,7 @@ replaySession sessionDir = do
 sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
 sendMessages [] _ _ = return ()
 sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
-  case nextMsg of
-    ReqInitialize               m -> request m
-    ReqShutdown                 m -> request m
-    ReqHover                    m -> request m
-    ReqCompletion               m -> request m
-    ReqCompletionItemResolve    m -> request m
-    ReqSignatureHelp            m -> request m
-    ReqDefinition               m -> request m
-    ReqFindReferences           m -> request m
-    ReqDocumentHighlights       m -> request m
-    ReqDocumentSymbols          m -> request m
-    ReqWorkspaceSymbols         m -> request m
-    ReqCodeAction               m -> request m
-    ReqCodeLens                 m -> request m
-    ReqCodeLensResolve          m -> request m
-    ReqDocumentFormatting       m -> request m
-    ReqDocumentRangeFormatting  m -> request m
-    ReqDocumentOnTypeFormatting m -> request m
-    ReqRename                   m -> request m
-    ReqExecuteCommand           m -> request m
-    ReqDocumentLink             m -> request m
-    ReqDocumentLinkResolve      m -> request m
-    ReqWillSaveWaitUntil        m -> request m
-    RspApplyWorkspaceEdit       m -> response m
-    RspFromClient               m -> response m
-    NotInitialized              m -> notification m
-    NotExit                     m -> notification m
-    NotCancelRequestFromClient  m -> notification m
-    NotDidChangeConfiguration   m -> notification m
-    NotDidOpenTextDocument      m -> notification m
-    NotDidChangeTextDocument    m -> notification m
-    NotDidCloseTextDocument     m -> notification m
-    NotWillSaveTextDocument     m -> notification m
-    NotDidSaveTextDocument      m -> notification m
-    NotDidChangeWatchedFiles    m -> notification m
-    UnknownFromClientMessage m -> liftIO $ error $ "Unknown message was recorded from the client" ++ show m
+  handleClientMessage request response notification nextMsg
  where
   -- TODO: May need to prevent premature exit notification being sent
   notification msg@(NotificationMessage _ Exit _) = do
@@ -136,7 +102,7 @@ sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
     if responseId reqId /= id
       then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
       else do
-        sendResponse' msg
+        sendResponse msg
         liftIO $ putStrLn $ "Sent response to request id " ++ show id
 
     sendMessages remainingMsgs reqSema rspSema
@@ -155,39 +121,7 @@ listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut  = do
   msgBytes <- liftIO $ getNextMessage serverOut
   let msg = decodeFromServerMsg reqMap msgBytes
   
-  case msg of
-    ReqRegisterCapability       m -> request m
-    ReqApplyWorkspaceEdit       m -> request m
-    ReqShowMessage              m -> request m
-    ReqUnregisterCapability     m -> request m
-    RspInitialize               m -> response m
-    RspShutdown                 m -> response m
-    RspHover                    m -> response m
-    RspCompletion               m -> response m
-    RspCompletionItemResolve    m -> response m
-    RspSignatureHelp            m -> response m
-    RspDefinition               m -> response m
-    RspFindReferences           m -> response m
-    RspDocumentHighlights       m -> response m
-    RspDocumentSymbols          m -> response m
-    RspWorkspaceSymbols         m -> response m
-    RspCodeAction               m -> response m
-    RspCodeLens                 m -> response m
-    RspCodeLensResolve          m -> response m
-    RspDocumentFormatting       m -> response m
-    RspDocumentRangeFormatting  m -> response m
-    RspDocumentOnTypeFormatting m -> response m
-    RspRename                   m -> response m
-    RspExecuteCommand           m -> response m
-    RspError                    m -> response m
-    RspDocumentLink             m -> response m
-    RspDocumentLinkResolve      m -> response m
-    RspWillSaveWaitUntil        m -> response m
-    NotPublishDiagnostics       m -> notification m
-    NotLogMessage               m -> notification m
-    NotShowMessage              m -> notification m
-    NotTelemetry                m -> notification m
-    NotCancelRequestFromServer  m -> notification m
+  handleServerMessage request response notification msg
 
   if shouldSkip msg
     then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut
@@ -199,17 +133,17 @@ listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut  = do
         print msg
         putStrLn "Expected one of:"
         mapM_ print $ takeWhile (not . isNotification) expectedMsgs
-        print $ head $ dropWhile (not . isNotification) expectedMsgs
+        print $ head $ dropWhile isNotification expectedMsgs
         putMVar passVar False
 
   where
-  response :: Show a => ResponseMessage a -> Session ()
+  response :: ResponseMessage a -> Session ()
   response res = do
     liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id)
 
     liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
 
-  request :: (Show a, Show b) => RequestMessage ServerMethod a b -> Session ()
+  request :: RequestMessage ServerMethod a b -> Session ()
   request req = do
     liftIO
       $  putStrLn
@@ -220,7 +154,7 @@ listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut  = do
 
     liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
 
-  notification :: Show a => NotificationMessage ServerMethod a -> Session ()
+  notification :: NotificationMessage ServerMethod a -> Session ()
   notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)