+-- | 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
+ -> RequestMap
+ -> (MVar LSP.LspIdRsp, MVar LSP.LspId)
+ -> Session ()
+listenServer [] _ _ _ = passSession
+listenServer expectedMsgs h reqMap semas@(reqSema, rspSema) = do
+ msgBytes <- lift $ getNextMessage h
+
+ let actualMsg = decodeFromServerMsg reqMap msgBytes
+
+ lift $ print actualMsg
+
+ newExpectedMsgs <- case actualMsg of
+ ReqRegisterCapability m -> request actualMsg m
+ ReqApplyWorkspaceEdit m -> request actualMsg m
+ ReqShowMessage m -> request actualMsg m
+ ReqUnregisterCapability m -> request actualMsg m
+ RspInitialize m -> response actualMsg m
+ RspShutdown m -> response actualMsg m
+ RspHover m -> response actualMsg m
+ RspCompletion m -> response actualMsg m
+ RspCompletionItemResolve m -> response actualMsg m
+ RspSignatureHelp m -> response actualMsg m
+ RspDefinition m -> response actualMsg m
+ RspFindReferences m -> response actualMsg m
+ RspDocumentHighlights m -> response actualMsg m
+ RspDocumentSymbols m -> response actualMsg m
+ RspWorkspaceSymbols m -> response actualMsg m
+ RspCodeAction m -> response actualMsg m
+ RspCodeLens m -> response actualMsg m
+ RspCodeLensResolve m -> response actualMsg m
+ RspDocumentFormatting m -> response actualMsg m
+ RspDocumentRangeFormatting m -> response actualMsg m
+ RspDocumentOnTypeFormatting m -> response actualMsg m
+ RspRename m -> response actualMsg m
+ RspExecuteCommand m -> response actualMsg m
+ RspError m -> response actualMsg m
+ RspDocumentLink m -> response actualMsg m
+ RspDocumentLinkResolve m -> response actualMsg m
+ RspWillSaveWaitUntil m -> response actualMsg m
+ NotPublishDiagnostics m -> notification actualMsg m
+ NotLogMessage m -> notification actualMsg m
+ NotShowMessage m -> notification actualMsg m
+ NotTelemetry m -> notification actualMsg m
+ NotCancelRequestFromServer m -> notification actualMsg m
+
+ listenServer newExpectedMsgs h reqMap semas
+ where
+ response
+ :: Show a
+ => FromServerMessage
+ -> LSP.ResponseMessage a
+ -> Session [FromServerMessage]
+ response msg res = do
+ lift $ putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
+
+ lift $ print res
+
+ checkOrder msg
+
+ lift $ putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
+
+ markReceived msg
+
+ request
+ :: (Show a, Show b)
+ => FromServerMessage
+ -> LSP.RequestMessage LSP.ServerMethod a b
+ -> Session [FromServerMessage]
+ request msg req = do
+ lift
+ $ putStrLn
+ $ "Got request for id "
+ ++ show (req ^. LSP.id)
+ ++ " "
+ ++ show (req ^. LSP.method)
+
+ lift $ print req
+
+ checkOrder msg
+
+ lift $ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
+
+ markReceived msg
+
+ notification
+ :: Show a
+ => FromServerMessage
+ -> LSP.NotificationMessage LSP.ServerMethod a
+ -> Session [FromServerMessage]
+ notification msg 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 msg
+
+ checkOrder msg = unless (inRightOrder msg expectedMsgs) $ failSession
+ ( "Out of order\nExpected\n"
+ ++ show firstExpected
+ ++ "\nGot\n"
+ ++ show msg
+ ++ "\n"
+ )
+
+ markReceived :: FromServerMessage -> Session [FromServerMessage]
+ markReceived msg =
+ 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 :: FromServerMessage -> [FromServerMessage] -> Bool
+
+inRightOrder _ [] = error "Why is this empty"
+-- inRightOrder (LSP.NotificationMessage _ _ _) _ = True
+
+inRightOrder received (expected : msgs)
+ | received == expected = True
+ | isNotification expected = inRightOrder received msgs
+ | otherwise = False