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
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
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
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)
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)
-- 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
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
setSGR [Reset]
B.hPut h (addHeader encoded)
+
+-- withTimeout :: Int -> Session a -> Session a
+-- withTimeout duration = do
+-- liftIO $ fork threadDelay