+ -- TODO: May need to prevent premature exit notification being sent
+ notification msg@(NotificationMessage _ Exit _) = do
+ liftIO $ putStrLn "Will send exit notification soon"
+ liftIO $ threadDelay 10000000
+ sendNotification' msg
+
+ liftIO $ error "Done"
+
+ notification msg@(NotificationMessage _ m _) = do
+ sendNotification' msg
+
+ liftIO $ putStrLn $ "Sent a notification " ++ show m
+
+ sendMessages remainingMsgs reqSema rspSema
+
+ request msg@(RequestMessage _ id m _) = do
+ sendRequest' msg
+ liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
+
+ rsp <- liftIO $ takeMVar rspSema
+ when (responseId id /= rsp) $
+ error $ "Expected id " ++ show id ++ ", got " ++ show rsp
+
+ sendMessages remainingMsgs reqSema rspSema
+
+ response msg@(ResponseMessage _ id _ _) = do
+ liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
+ reqId <- liftIO $ takeMVar reqSema
+ if responseId reqId /= id
+ then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
+ else do
+ sendResponse' msg
+ liftIO $ putStrLn $ "Sent response to request id " ++ show id
+
+ sendMessages remainingMsgs reqSema rspSema
+
+
+isNotification :: FromServerMessage -> Bool
+isNotification (NotPublishDiagnostics _) = True
+isNotification (NotLogMessage _) = True
+isNotification (NotShowMessage _) = True
+isNotification (NotCancelRequestFromServer _) = True
+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 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
+
+ if shouldSkip msg
+ then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut
+ else if inRightOrder msg expectedMsgs
+ then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut
+ else liftIO $ do
+ putStrLn "Out of order"
+ putStrLn "Got:"
+ print msg
+ putStrLn "Expected one of:"
+ mapM_ print $ takeWhile (not . isNotification) expectedMsgs
+ print $ head $ dropWhile (not . isNotification) expectedMsgs
+ putMVar passVar False
+
+ where
+ response :: Show a => 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 req = do
+ liftIO
+ $ putStrLn
+ $ "Got request for id "
+ ++ show (req ^. id)
+ ++ " "
+ ++ show (req ^. method)
+
+ liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
+
+ notification :: Show a => NotificationMessage ServerMethod a -> Session ()
+ notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)
+
+
+
+-- 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 :: FromServerMessage -> [FromServerMessage] -> Bool
+
+inRightOrder _ [] = error "Why is this empty"
+
+inRightOrder received (expected : msgs)
+ | received == expected = True
+ | isNotification expected = inRightOrder received msgs
+ | otherwise = False
+
+-- | Ignore logging notifications since they vary from session to session
+shouldSkip :: FromServerMessage -> Bool
+shouldSkip (NotLogMessage _) = True
+shouldSkip (NotShowMessage _) = True
+shouldSkip (ReqShowMessage _) = True
+shouldSkip _ = False