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 hiding (error)
import Data.Aeson
import Data.Default
import Data.List
import Data.Maybe
import Control.Lens hiding (List)
import Control.Monad
-import System.IO
import System.FilePath
+import System.IO
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
-- makes sure it matches up with an expected response.
-- 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
serverOut
(listenServer serverMsgs requestMap reqSema rspSema passSema mainThread)
def
+ fullCaps
sessionDir
(sendMessages clientMsgs reqSema rspSema)
takeMVar passSema
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
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
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
+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 <- liftIO $ getNextMessage serverOut
+ 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)