Remove superfluous Session handler

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index b406e7bd4e87a5a068d59b44e7b27678b100a64e..4cad784156477f23f4cefdb482de94764ac7d215 100644 (file)
--- 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 250fb2acb7537c783e01e4782853e059089bec51..b224be6cbf0132a6e50b6bc0380edd453ac94e2d 100644 (file)
--- 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 ec6d45dc1ed3fbb18ebb8e239cf2d08287762ed6..eb75fda1db2c8fd5d5c1bdf010f77dd5544cb30a 100644 (file)
--- 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