From fe5448266f5db772dd3f10be432cd56581bbcb40 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Sat, 7 Jul 2018 22:51:47 +0100 Subject: [PATCH] Remove superfluous Session handler --- src/Language/Haskell/LSP/Test.hs | 17 +++++----- src/Language/Haskell/LSP/Test/Replay.hs | 40 ++++++++++++++---------- src/Language/Haskell/LSP/Test/Session.hs | 10 +++--- 3 files changed, 37 insertions(+), 30 deletions(-) diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index b406e7b..4cad784 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -94,7 +94,7 @@ import Data.Default import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import Data.Maybe -import Language.Haskell.LSP.Types hiding (id, capabilities, error) +import Language.Haskell.LSP.Types hiding (id, capabilities) import qualified Language.Haskell.LSP.Types as LSP import Language.Haskell.LSP.Messages import Language.Haskell.LSP.VFS @@ -151,20 +151,19 @@ runSessionWithConfig config serverExe rootDir session = do sendNotification Exit ExitParams return result - + where -- | Listens to the server output, makes sure it matches the record and -- signals any semaphores -listenServer :: Handle -> Session () -listenServer serverOut = do - msgBytes <- liftIO $ getNextMessage serverOut + listenServer :: Handle -> SessionContext -> IO () + listenServer serverOut context = do + msgBytes <- getNextMessage serverOut - context <- ask - reqMap <- liftIO $ readMVar $ requestMap context + reqMap <- readMVar $ requestMap context let msg = decodeFromServerMsg reqMap msgBytes - liftIO $ writeChan (messageChan context) msg + writeChan (messageChan context) msg - listenServer serverOut + listenServer serverOut context -- | The current text contents of a document. documentContents :: TextDocumentIdentifier -> Session T.Text diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs index 250fb2a..b224be6 100644 --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@ -19,7 +19,6 @@ import Data.List import Data.Maybe import Control.Lens hiding (List) import Control.Monad -import System.IO import System.FilePath import Language.Haskell.LSP.Test import Language.Haskell.LSP.Test.Files @@ -123,44 +122,51 @@ isNotification (NotShowMessage _) = 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 - - msgBytes <- liftIO $ getNextMessage serverOut +-- 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 <- 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 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) diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index ec6d45d..eb75fda 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -131,7 +131,6 @@ type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m)) type SessionProcessor = ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) - runSession :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState) runSession chan preprocessor context state session = runReaderT (runStateT conduit state) context where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser (catchError session handler) @@ -161,7 +160,7 @@ runSession chan preprocessor context state session = runReaderT (runStateT condu -- It also does not automatically send initialize and exit messages. runSessionWithHandles :: Handle -- ^ Server in -> Handle -- ^ Server out - -> (Handle -> Session ()) -- ^ Server listener + -> (Handle -> SessionContext -> IO ()) -- ^ Server listener -> SessionConfig -> FilePath -> Session a @@ -174,13 +173,12 @@ runSessionWithHandles serverIn serverOut serverHandler config rootDir session = reqMap <- newMVar newRequestMap messageChan <- newChan - meaninglessChan <- newChan initRsp <- newEmptyMVar let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config initState = SessionState (IdInt 0) mempty mempty - threadId <- forkIO $ void $ runSession meaninglessChan processor context initState (serverHandler serverOut) + threadId <- forkIO $ void $ serverHandler serverOut context (result, _) <- runSession messageChan processor context initState session killThread threadId @@ -265,3 +263,7 @@ sendMessage msg = do setSGR [Reset] B.hPut h (addHeader encoded) + +-- withTimeout :: Int -> Session a -> Session a +-- withTimeout duration = do +-- liftIO $ fork threadDelay -- 2.30.2