X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FSession.hs;h=1abad54d673728031afabbbd332fcebc396631f8;hb=a8e8371de3168f0faae2f33eae0d97f466c4786f;hp=21a5fe7002af4061552c390bbc24442bec4786d2;hpb=fa278340d5f1bc915a250bede93258a45234ba1a;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index 21a5fe7..1abad54 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -1,12 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} module Language.Haskell.LSP.Test.Session - ( Session + ( Session(..) , SessionConfig(..) , defaultConfig , SessionMessage(..) @@ -28,19 +29,20 @@ module Language.Haskell.LSP.Test.Session where +import Control.Applicative import Control.Concurrent hiding (yield) import Control.Exception import Control.Lens hiding (List) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Except -#if __GLASGOW_HASKELL__ >= 806 +#if __GLASGOW_HASKELL__ == 806 import Control.Monad.Fail #endif import Control.Monad.Trans.Reader (ReaderT, runReaderT) import qualified Control.Monad.Trans.Reader as Reader (ask) import Control.Monad.Trans.State (StateT, runStateT) -import qualified Control.Monad.Trans.State as State (get, put) +import qualified Control.Monad.Trans.State as State import qualified Data.ByteString.Lazy.Char8 as B import Data.Aeson import Data.Aeson.Encode.Pretty @@ -60,11 +62,13 @@ import Language.Haskell.LSP.Types.Capabilities import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens hiding (error) import Language.Haskell.LSP.VFS +import Language.Haskell.LSP.Test.Compat import Language.Haskell.LSP.Test.Decoding import Language.Haskell.LSP.Test.Exceptions import System.Console.ANSI import System.Directory import System.IO +import System.Process (ProcessHandle()) import System.Timeout -- | A session representing one instance of launching and connecting to a server. @@ -74,7 +78,10 @@ import System.Timeout -- 'Language.Haskell.LSP.Test.sendRequest' and -- 'Language.Haskell.LSP.Test.sendNotification'. -type Session = ParserStateReader FromServerMessage SessionState SessionContext IO +-- newtype Session a = Session (ParserStateReader FromServerMessage SessionState SessionContext IO a) + +newtype Session a = Session (ConduitParser FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) a) + deriving (Functor, Applicative, Monad, MonadIO, Alternative) #if __GLASGOW_HASKELL__ >= 806 instance MonadFail Session where @@ -119,10 +126,10 @@ class Monad m => HasReader r m where asks :: (r -> b) -> m b asks f = f <$> ask -instance Monad m => HasReader r (ParserStateReader a s r m) where - ask = lift $ lift Reader.ask +instance HasReader SessionContext Session where + ask = Session (lift $ lift Reader.ask) -instance Monad m => HasReader SessionContext (ConduitM a b (StateT s (ReaderT SessionContext m))) where +instance Monad m => HasReader r (ConduitM a b (StateT s (ReaderT r m))) where ask = lift $ lift Reader.ask data SessionState = SessionState @@ -148,19 +155,22 @@ class Monad m => HasState s m where modifyM :: (HasState s m, Monad m) => (s -> m s) -> m () modifyM f = get >>= f >>= put -instance Monad m => HasState s (ParserStateReader a s r m) where +instance HasState SessionState Session where + get = Session (lift State.get) + put = Session . lift . State.put + +instance Monad m => HasState s (ConduitM a b (StateT s m)) + where get = lift State.get put = lift . State.put -instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m)) +instance Monad m => HasState s (ConduitParser a (StateT s m)) where get = lift State.get put = lift . State.put -type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m)) - runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState) -runSession context state session = runReaderT (runStateT conduit state) context +runSession context state (Session session) = runReaderT (runStateT conduit state) context where conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler) @@ -187,15 +197,15 @@ runSession context state session = runReaderT (runStateT conduit state) context -- It also does not automatically send initialize and exit messages. runSessionWithHandles :: Handle -- ^ Server in -> Handle -- ^ Server out + -> ProcessHandle -- ^ Server process -> (Handle -> SessionContext -> IO ()) -- ^ Server listener -> SessionConfig -> ClientCapabilities -> FilePath -- ^ Root directory - -> Session () -- ^ To exit Server + -> Session () -- ^ To exit the Server properly -> Session a -> IO a -runSessionWithHandles serverIn serverOut serverHandler config caps rootDir exitServer session = do - +runSessionWithHandles serverIn serverOut serverProc serverHandler config caps rootDir exitServer session = do absRootDir <- canonicalizePath rootDir hSetBuffering serverIn NoBuffering @@ -216,11 +226,16 @@ runSessionWithHandles serverIn serverOut serverHandler config caps rootDir exitS runSession' = runSession context initState errorHandler = throwTo mainThreadId :: SessionException -> IO() - serverLauncher = forkIO $ catch (serverHandler serverOut context) errorHandler - serverFinalizer tid = finally (timeout 60000000 (runSession' exitServer)) - (killThread tid) - - (result, _) <- bracket serverLauncher serverFinalizer (const $ runSession' session) + serverListenerLauncher = + forkIO $ catch (serverHandler serverOut context) errorHandler + server = (Just serverIn, Just serverOut, Nothing, serverProc) + serverAndListenerFinalizer tid = + finally (timeout (messageTimeout config * 1000000) + (runSession' exitServer)) + (cleanupProcess server >> killThread tid) + + (result, _) <- bracket serverListenerLauncher serverAndListenerFinalizer + (const $ runSession' session) return result updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () @@ -228,7 +243,8 @@ updateStateC = awaitForever $ \msg -> do updateState msg yield msg -updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m () +updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) + => FromServerMessage -> m () updateState (NotPublishDiagnostics n) = do let List diags = n ^. params . diagnostics doc = n ^. params . uri