threadDelay (timeout * 1000000)
writeChan chan (TimeoutMessage timeoutId)
- x <- await
+ x <- Session await
unless skipTimeout $
modify $ \s -> s { curTimeoutId = timeoutId + 1 }
message :: forall a. (Typeable a, FromJSON a) => Session a
message =
let parser = decode . encodeMsg :: FromServerMessage -> Maybe a
- in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $
- satisfyMaybe parser
+ in satisfyMaybe parser
-- | Matches if the message is a notification.
anyNotification :: Session FromServerMessage
-anyNotification = named "Any notification" $ satisfy isServerNotification
+anyNotification = satisfy isServerNotification
-- | Matches if the message is a request.
anyRequest :: Session FromServerMessage
-anyRequest = named "Any request" $ satisfy isServerRequest
+anyRequest = satisfy isServerRequest
-- | Matches if the message is a response.
anyResponse :: Session FromServerMessage
-anyResponse = named "Any response" $ satisfy isServerResponse
+anyResponse = satisfy isServerResponse
-- | Matches a response for a specific id.
responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a)
-responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do
+responseForId lid = do
let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
satisfyMaybe $ \msg -> do
z <- parser msg
-- | Matches if the message is a log message notification or a show message notification/request.
loggingNotification :: Session FromServerMessage
-loggingNotification = named "Logging notification" $ satisfy shouldSkip
+loggingNotification = satisfy shouldSkip
where
shouldSkip (NotLogMessage _) = True
shouldSkip (NotShowMessage _) = True
-- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification'
-- (textDocument/publishDiagnostics) notification.
publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
-publishDiagnosticsNotification = named "Publish diagnostics notification" $
- satisfyMaybe $ \msg -> case msg of
+publishDiagnosticsNotification = satisfyMaybe $
+ \msg -> case msg of
NotPublishDiagnostics diags -> Just diags
_ -> Nothing
{-# 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(..)
where
+import Control.Applicative
import Control.Concurrent hiding (yield)
import Control.Exception
import Control.Lens hiding (List)
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
-- '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
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
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)
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