+ -- TODO: May need to prevent premature exit notification being sent
+ notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
+ putStrLn "Will send exit notification soon"
+ threadDelay 10000000
+ B.hPut serverH $ addHeader (encode msg)
+ notification msg@(LSP.NotificationMessage _ m _) = do
+ B.hPut serverH $ addHeader (encode msg)
+
+ putStrLn $ "Sent a notification " ++ show m
+
+ request msg@(LSP.RequestMessage _ id m _) = do
+
+ when (m == LSP.TextDocumentDocumentSymbol) $ threadDelay 5000000
+
+ B.hPut serverH $ addHeader (encode msg)
+ putStrLn
+ $ "Sent a request id "
+ ++ show id
+ ++ ": "
+ ++ show m
+ ++ "\nWaiting for a response"
+
+ rspId <- takeMVar reqSema
+ when (LSP.responseId id /= rspId)
+ $ error
+ $ "Expected id "
+ ++ show id
+ ++ ", got "
+ ++ show rspId
+
+ response msg@(LSP.ResponseMessage _ id _ _) = do
+ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
+ reqId <- takeMVar rspSema
+ if LSP.responseId reqId /= id
+ then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
+ else do
+ B.hPut serverH $ addHeader (encode msg)
+ putStrLn $ "Sent response to request id " ++ show id
+
+-- | The internal monad for tests that can fail or pass,
+-- ending execution early.
+type Session = ReaderT (MVar Bool) IO
+
+-- TODO: Make return type polymoprhic more like error
+failSession :: String -> Session ()
+failSession reason = do
+ lift $ putStrLn reason
+ passVar <- ask
+ lift $ putMVar passVar False
+
+passSession :: Session ()
+passSession = do
+ passVar <- ask
+ lift $ putMVar passVar True
+
+-- | Listens to the server output, makes sure it matches the record and
+-- signals any semaphores
+listenServer :: [FromServerMessage] -> Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Session ()
+listenServer [] _ _ = passSession
+listenServer expectedMsgs h semas@(reqSema, rspSema) = do
+ msg <- lift $ getNextMessage h
+
+ newExpectedMsgs <- case decode msg of
+ Just m -> request m
+ Nothing -> case decode msg of
+ Just m -> notification m
+ Nothing -> case decode msg of
+ Just m -> response m
+ Nothing -> failSession "Malformed message" >> return expectedMsgs
+
+ listenServer newExpectedMsgs h semas
+
+ where response :: LSP.ResponseMessage a -> Session [FromServerMessage]
+ response res = do
+ lift $ putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
+
+ lift $ print res
+
+ checkOrder res
+
+ lift $ putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
+
+ markReceived res
+
+ request :: LSP.RequestMessage LSP.ServerMethod a b -> Session [FromServerMessage]
+ request req = do
+ lift $ putStrLn $ "Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method)
+
+ lift $ print req
+
+ checkOrder req
+
+ lift $ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
+
+ markReceived req
+
+ notification :: LSP.NotificationMessage LSP.ServerMethod a -> Session [FromServerMessage]
+ notification n = do
+ lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
+ lift $ print n
+
+ lift $ putStrLn $ show (length (filter isNotification expectedMsgs) - 1) ++ " notifications remaining"
+
+ if n ^. LSP.method == LSP.WindowLogMessage
+ then return expectedMsgs
+ else markReceived n
+
+ checkOrder msg = unless (inRightOrder msg expectedMsgs) $ do
+ let (Just expected) = decode firstExpected
+ _ = expected == msg -- make expected type same as res
+ failSession ("Out of order\nExpected\n" ++ show expected ++ "\nGot\n" ++ show msg ++ "\n")
+
+ markReceived :: Eq a => a -> [FromServerMessage] -> Session [FromServerMessage]
+ markReceived msg =
+ -- TODO: Find some way of equating FromServerMessage and LSP.ResponseMessage etc.
+ let new = delete msg expectedMsgs
+ in if new == expectedMsgs
+ then failSession ("Unexpected message: " ++ show msg) >> return new
+ else return new
+
+ firstExpected = head $ filter (not . isNotification) expectedMsgs
+
+isNotification :: FromServerMessage -> Bool
+isNotification (NotPublishDiagnostics _) = True
+isNotification (NotLogMessage _) = True
+isNotification (NotShowMessage _) = True
+isNotification (NotCancelRequestFromServer _) = True
+isNotification _ = False
+
+-- TODO: QuickCheck tests?
+-- | Checks wether or not the message appears in the right order
+-- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
+-- given N2, notification order doesn't matter.
+-- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
+-- given REQ1
+-- @ N1 N3 N4 N5 REQ2 RES1 @
+-- given RES1
+-- @ N1 N3 N4 N5 XXXX RES1 @ False!
+-- Order of requests and responses matter
+inRightOrder :: (FromJSON a, Eq a) => a -> [B.ByteString] -> Bool
+
+inRightOrder _ [] = error "Why is this empty"
+-- inRightOrder (LSP.NotificationMessage _ _ _) _ = True
+
+inRightOrder received (expected:msgs)
+ | Just received == decode expected = True
+ | isNotification expected = inRightOrder received msgs
+ | otherwise = False
\ No newline at end of file