From: Luke Lau Date: Sat, 5 Oct 2019 23:37:12 +0000 (+0100) Subject: Merge pull request #52 from bubba/session-newtype X-Git-Tag: 0.8.0.0~3 X-Git-Url: http://git.lukelau.me/?p=lsp-test.git;a=commitdiff_plain;h=3fedb8ff9e5720da944cf4d2cd4ad5afff0d10af;hp=50a0c87ace126635ec152ad05fdce698a8dc0310 Merge pull request #52 from bubba/session-newtype Make Session a newtype --- diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 1b2e7ba..61fc908 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -8,7 +8,7 @@ Module : Language.Haskell.LSP.Test Description : A functional testing framework for LSP servers. Maintainer : luke_lau@icloud.com Stability : experimental -Portability : POSIX +Portability : non-portable Provides the framework to start functionally testing . @@ -163,8 +163,7 @@ runSessionWithConfig config serverExe caps rootDir session = do Nothing -> return () -- Run the actual test - result <- session - return result + session where -- | Asks the server to shutdown and exit politely exitServer :: Session () diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index 52f97ae..70481b9 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -23,7 +23,8 @@ import Control.Monad.IO.Class import Control.Monad import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as B -import Data.Conduit.Parser +import Data.Conduit.Parser hiding (named) +import qualified Data.Conduit.Parser (named) import qualified Data.Text as T import Data.Typeable import Language.Haskell.LSP.Messages @@ -81,7 +82,7 @@ satisfyMaybe pred = do threadDelay (timeout * 1000000) writeChan chan (TimeoutMessage timeoutId) - x <- await + x <- Session await unless skipTimeout $ modify $ \s -> s { curTimeoutId = timeoutId + 1 } @@ -94,6 +95,9 @@ satisfyMaybe pred = do return a Nothing -> empty +named :: T.Text -> Session a -> Session a +named s (Session x) = Session (Data.Conduit.Parser.named s x) + -- | Matches a message of type @a@. message :: forall a. (Typeable a, FromJSON a) => Session a message = diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index b8286a2..b8dbe2a 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,6 +29,7 @@ module Language.Haskell.LSP.Test.Session where +import Control.Applicative import Control.Concurrent hiding (yield) import Control.Exception import Control.Lens hiding (List) @@ -40,7 +42,7 @@ import Control.Monad.Fail 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 @@ -76,7 +78,8 @@ 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 (ConduitParser FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) a) + deriving (Functor, Applicative, Monad, MonadIO, Alternative) #if __GLASGOW_HASKELL__ >= 806 instance MonadFail Session where @@ -121,10 +124,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 @@ -150,19 +153,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) @@ -235,7 +241,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