{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

module Language.Haskell.LSP.Test.Session
  ( Session(..)
  , SessionConfig(..)
  , defaultConfig
  , SessionMessage(..)
  , SessionContext(..)
  , SessionState(..)
  , runSessionWithHandles
  , get
  , put
  , modify
  , modifyM
  , ask
  , asks
  , sendMessage
  , updateState
  , withTimeout
  , getCurTimeoutId
  , bumpTimeoutId
  , logMsg
  , LogMsgType(..)
  )

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
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
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Aeson
import Data.Aeson.Encode.Pretty
import Data.Conduit as Conduit
import Data.Conduit.Parser as Parser
import Data.Default
import Data.Foldable
import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe
import Data.Function
import Language.Haskell.LSP.Messages
import Language.Haskell.LSP.Types.Capabilities
import Language.Haskell.LSP.Types
import Language.Haskell.LSP.Types.Lens
import qualified Language.Haskell.LSP.Types.Lens as LSP
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())
#ifndef mingw32_HOST_OS
import System.Process (waitForProcess)
#endif
import System.Timeout

-- | A session representing one instance of launching and connecting to a server.
--
-- You can send and receive messages to the server within 'Session' via
-- 'Language.Haskell.LSP.Test.message',
-- 'Language.Haskell.LSP.Test.sendRequest' and
-- 'Language.Haskell.LSP.Test.sendNotification'.

newtype Session a = Session (ConduitParser FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) a)
  deriving (a -> Session b -> Session a
(a -> b) -> Session a -> Session b
(forall a b. (a -> b) -> Session a -> Session b)
-> (forall a b. a -> Session b -> Session a) -> Functor Session
forall a b. a -> Session b -> Session a
forall a b. (a -> b) -> Session a -> Session b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Session b -> Session a
$c<$ :: forall a b. a -> Session b -> Session a
fmap :: (a -> b) -> Session a -> Session b
$cfmap :: forall a b. (a -> b) -> Session a -> Session b
Functor, Functor Session
a -> Session a
Functor Session
-> (forall a. a -> Session a)
-> (forall a b. Session (a -> b) -> Session a -> Session b)
-> (forall a b c.
    (a -> b -> c) -> Session a -> Session b -> Session c)
-> (forall a b. Session a -> Session b -> Session b)
-> (forall a b. Session a -> Session b -> Session a)
-> Applicative Session
Session a -> Session b -> Session b
Session a -> Session b -> Session a
Session (a -> b) -> Session a -> Session b
(a -> b -> c) -> Session a -> Session b -> Session c
forall a. a -> Session a
forall a b. Session a -> Session b -> Session a
forall a b. Session a -> Session b -> Session b
forall a b. Session (a -> b) -> Session a -> Session b
forall a b c. (a -> b -> c) -> Session a -> Session b -> Session c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Session a -> Session b -> Session a
$c<* :: forall a b. Session a -> Session b -> Session a
*> :: Session a -> Session b -> Session b
$c*> :: forall a b. Session a -> Session b -> Session b
liftA2 :: (a -> b -> c) -> Session a -> Session b -> Session c
$cliftA2 :: forall a b c. (a -> b -> c) -> Session a -> Session b -> Session c
<*> :: Session (a -> b) -> Session a -> Session b
$c<*> :: forall a b. Session (a -> b) -> Session a -> Session b
pure :: a -> Session a
$cpure :: forall a. a -> Session a
$cp1Applicative :: Functor Session
Applicative, Applicative Session
a -> Session a
Applicative Session
-> (forall a b. Session a -> (a -> Session b) -> Session b)
-> (forall a b. Session a -> Session b -> Session b)
-> (forall a. a -> Session a)
-> Monad Session
Session a -> (a -> Session b) -> Session b
Session a -> Session b -> Session b
forall a. a -> Session a
forall a b. Session a -> Session b -> Session b
forall a b. Session a -> (a -> Session b) -> Session b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Session a
$creturn :: forall a. a -> Session a
>> :: Session a -> Session b -> Session b
$c>> :: forall a b. Session a -> Session b -> Session b
>>= :: Session a -> (a -> Session b) -> Session b
$c>>= :: forall a b. Session a -> (a -> Session b) -> Session b
$cp1Monad :: Applicative Session
Monad, Monad Session
Monad Session -> (forall a. IO a -> Session a) -> MonadIO Session
IO a -> Session a
forall a. IO a -> Session a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> Session a
$cliftIO :: forall a. IO a -> Session a
$cp1MonadIO :: Monad Session
MonadIO, Applicative Session
Session a
Applicative Session
-> (forall a. Session a)
-> (forall a. Session a -> Session a -> Session a)
-> (forall a. Session a -> Session [a])
-> (forall a. Session a -> Session [a])
-> Alternative Session
Session a -> Session a -> Session a
Session a -> Session [a]
Session a -> Session [a]
forall a. Session a
forall a. Session a -> Session [a]
forall a. Session a -> Session a -> Session a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
many :: Session a -> Session [a]
$cmany :: forall a. Session a -> Session [a]
some :: Session a -> Session [a]
$csome :: forall a. Session a -> Session [a]
<|> :: Session a -> Session a -> Session a
$c<|> :: forall a. Session a -> Session a -> Session a
empty :: Session a
$cempty :: forall a. Session a
$cp1Alternative :: Applicative Session
Alternative)

#if __GLASGOW_HASKELL__ >= 806
instance MonadFail Session where
  fail :: String -> Session a
fail String
s = do
    FromServerMessage
lastMsg <- Maybe FromServerMessage -> FromServerMessage
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe FromServerMessage -> FromServerMessage)
-> (SessionState -> Maybe FromServerMessage)
-> SessionState
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionState -> Maybe FromServerMessage
lastReceivedMessage (SessionState -> FromServerMessage)
-> Session SessionState -> Session FromServerMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session SessionState
forall s (m :: * -> *). HasState s m => m s
get
    IO a -> Session a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Session a) -> IO a -> Session a
forall a b. (a -> b) -> a -> b
$ SessionException -> IO a
forall a e. Exception e => e -> a
throw (String -> FromServerMessage -> SessionException
UnexpectedMessage String
s FromServerMessage
lastMsg)
#endif

-- | Stuff you can configure for a 'Session'.
data SessionConfig = SessionConfig
  { SessionConfig -> Int
messageTimeout :: Int  -- ^ Maximum time to wait for a message in seconds, defaults to 60.
  , SessionConfig -> Bool
logStdErr      :: Bool
  -- ^ Redirect the server's stderr to this stdout, defaults to False.
  -- Can be overriden with @LSP_TEST_LOG_STDERR@.
  , SessionConfig -> Bool
logMessages    :: Bool
  -- ^ Trace the messages sent and received to stdout, defaults to False.
  -- Can be overriden with the environment variable @LSP_TEST_LOG_MESSAGES@.
  , SessionConfig -> Bool
logColor       :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.
  , SessionConfig -> Maybe Value
lspConfig      :: Maybe Value -- ^ The initial LSP config as JSON value, defaults to Nothing.
  , SessionConfig -> Bool
ignoreLogNotifications :: Bool
  -- ^ Whether or not to ignore 'Language.Haskell.LSP.Types.ShowMessageNotification' and
  -- 'Language.Haskell.LSP.Types.LogMessageNotification', defaults to False.
  --
  -- @since 0.9.0.0
  }

-- | The configuration used in 'Language.Haskell.LSP.Test.runSession'.
defaultConfig :: SessionConfig
defaultConfig :: SessionConfig
defaultConfig = Int -> Bool -> Bool -> Bool -> Maybe Value -> Bool -> SessionConfig
SessionConfig Int
60 Bool
False Bool
False Bool
True Maybe Value
forall a. Maybe a
Nothing Bool
False

instance Default SessionConfig where
  def :: SessionConfig
def = SessionConfig
defaultConfig

data SessionMessage = ServerMessage FromServerMessage
                    | TimeoutMessage Int
  deriving Int -> SessionMessage -> ShowS
[SessionMessage] -> ShowS
SessionMessage -> String
(Int -> SessionMessage -> ShowS)
-> (SessionMessage -> String)
-> ([SessionMessage] -> ShowS)
-> Show SessionMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SessionMessage] -> ShowS
$cshowList :: [SessionMessage] -> ShowS
show :: SessionMessage -> String
$cshow :: SessionMessage -> String
showsPrec :: Int -> SessionMessage -> ShowS
$cshowsPrec :: Int -> SessionMessage -> ShowS
Show

data SessionContext = SessionContext
  {
    SessionContext -> Handle
serverIn :: Handle
  , SessionContext -> String
rootDir :: FilePath
  , SessionContext -> Chan SessionMessage
messageChan :: Chan SessionMessage -- ^ Where all messages come through
  -- Keep curTimeoutId in SessionContext, as its tied to messageChan
  , SessionContext -> MVar Int
curTimeoutId :: MVar Int -- ^ The current timeout we are waiting on
  , SessionContext -> MVar RequestMap
requestMap :: MVar RequestMap
  , SessionContext -> MVar InitializeResponse
initRsp :: MVar InitializeResponse
  , SessionContext -> SessionConfig
config :: SessionConfig
  , SessionContext -> ClientCapabilities
sessionCapabilities :: ClientCapabilities
  }

class Monad m => HasReader r m where
  ask :: m r
  asks :: (r -> b) -> m b
  asks r -> b
f = r -> b
f (r -> b) -> m r -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m r
forall r (m :: * -> *). HasReader r m => m r
ask

instance HasReader SessionContext Session where
  ask :: Session SessionContext
ask  = ConduitParser
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  SessionContext
-> Session SessionContext
forall a.
ConduitParser
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  a
-> Session a
Session (StateT SessionState (ReaderT SessionContext IO) SessionContext
-> ConduitParser
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     SessionContext
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT SessionState (ReaderT SessionContext IO) SessionContext
 -> ConduitParser
      FromServerMessage
      (StateT SessionState (ReaderT SessionContext IO))
      SessionContext)
-> StateT SessionState (ReaderT SessionContext IO) SessionContext
-> ConduitParser
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     SessionContext
forall a b. (a -> b) -> a -> b
$ ReaderT SessionContext IO SessionContext
-> StateT SessionState (ReaderT SessionContext IO) SessionContext
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT SessionContext IO SessionContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
Reader.ask)

instance Monad m => HasReader r (ConduitM a b (StateT s (ReaderT r m))) where
  ask :: ConduitM a b (StateT s (ReaderT r m)) r
ask = StateT s (ReaderT r m) r -> ConduitM a b (StateT s (ReaderT r m)) r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT s (ReaderT r m) r
 -> ConduitM a b (StateT s (ReaderT r m)) r)
-> StateT s (ReaderT r m) r
-> ConduitM a b (StateT s (ReaderT r m)) r
forall a b. (a -> b) -> a -> b
$ ReaderT r m r -> StateT s (ReaderT r m) r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT r m r
forall (m :: * -> *) r. Monad m => ReaderT r m r
Reader.ask

getCurTimeoutId :: (HasReader SessionContext m, MonadIO m) => m Int
getCurTimeoutId :: m Int
getCurTimeoutId = (SessionContext -> MVar Int) -> m (MVar Int)
forall r (m :: * -> *) b. HasReader r m => (r -> b) -> m b
asks SessionContext -> MVar Int
curTimeoutId m (MVar Int) -> (MVar Int -> m Int) -> m Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> (MVar Int -> IO Int) -> MVar Int -> m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar Int -> IO Int
forall a. MVar a -> IO a
readMVar

-- Pass this the timeoutid you *were* waiting on
bumpTimeoutId :: (HasReader SessionContext m, MonadIO m) => Int -> m ()
bumpTimeoutId :: Int -> m ()
bumpTimeoutId Int
prev = do
  MVar Int
v <- (SessionContext -> MVar Int) -> m (MVar Int)
forall r (m :: * -> *) b. HasReader r m => (r -> b) -> m b
asks SessionContext -> MVar Int
curTimeoutId
  -- when updating the curtimeoutid, account for the fact that something else
  -- might have bumped the timeoutid in the meantime
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar Int -> (Int -> IO Int) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Int
v (\Int
x -> Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
x (Int
prev Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)))

data SessionState = SessionState
  {
    SessionState -> LspId
curReqId :: LspId
  , SessionState -> VFS
vfs :: VFS
  , SessionState -> Map NormalizedUri [Diagnostic]
curDiagnostics :: Map.Map NormalizedUri [Diagnostic]
  , SessionState -> Bool
overridingTimeout :: Bool
  -- ^ The last received message from the server.
  -- Used for providing exception information
  , SessionState -> Maybe FromServerMessage
lastReceivedMessage :: Maybe FromServerMessage
  , SessionState -> Map Text Registration
curDynCaps :: Map.Map T.Text Registration
  -- ^ The capabilities that the server has dynamically registered with us so
  -- far
  , SessionState -> Set ProgressToken
curProgressSessions :: Set.Set ProgressToken
  }

class Monad m => HasState s m where
  get :: m s

  put :: s -> m ()

  modify :: (s -> s) -> m ()
  modify s -> s
f = m s
forall s (m :: * -> *). HasState s m => m s
get m s -> (s -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> m ()
forall s (m :: * -> *). HasState s m => s -> m ()
put (s -> m ()) -> (s -> s) -> s -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> s
f

  modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()
  modifyM s -> m s
f = m s
forall s (m :: * -> *). HasState s m => m s
get m s -> (s -> m s) -> m s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> m s
f m s -> (s -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> m ()
forall s (m :: * -> *). HasState s m => s -> m ()
put

instance HasState SessionState Session where
  get :: Session SessionState
get = ConduitParser
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  SessionState
-> Session SessionState
forall a.
ConduitParser
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  a
-> Session a
Session (StateT SessionState (ReaderT SessionContext IO) SessionState
-> ConduitParser
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     SessionState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT SessionState (ReaderT SessionContext IO) SessionState
forall (m :: * -> *) s. Monad m => StateT s m s
State.get)
  put :: SessionState -> Session ()
put = ConduitParser
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
-> Session ()
forall a.
ConduitParser
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  a
-> Session a
Session (ConduitParser
   FromServerMessage
   (StateT SessionState (ReaderT SessionContext IO))
   ()
 -> Session ())
-> (SessionState
    -> ConduitParser
         FromServerMessage
         (StateT SessionState (ReaderT SessionContext IO))
         ())
-> SessionState
-> Session ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT SessionState (ReaderT SessionContext IO) ()
-> ConduitParser
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT SessionState (ReaderT SessionContext IO) ()
 -> ConduitParser
      FromServerMessage
      (StateT SessionState (ReaderT SessionContext IO))
      ())
-> (SessionState
    -> StateT SessionState (ReaderT SessionContext IO) ())
-> SessionState
-> ConduitParser
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionState -> StateT SessionState (ReaderT SessionContext IO) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put

instance Monad m => HasState s (StateT s m) where
  get :: StateT s m s
get = StateT s m s
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
  put :: s -> StateT s m ()
put = s -> StateT s m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put

instance (Monad m, (HasState s m)) => HasState s (ConduitM a b m)
 where
  get :: ConduitM a b m s
get = m s -> ConduitM a b m s
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m s
forall s (m :: * -> *). HasState s m => m s
get
  put :: s -> ConduitM a b m ()
put = m () -> ConduitM a b m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ConduitM a b m ())
-> (s -> m ()) -> s -> ConduitM a b m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m ()
forall s (m :: * -> *). HasState s m => s -> m ()
put

instance (Monad m, (HasState s m)) => HasState s (ConduitParser a m)
 where
  get :: ConduitParser a m s
get = m s -> ConduitParser a m s
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m s
forall s (m :: * -> *). HasState s m => m s
get
  put :: s -> ConduitParser a m ()
put = m () -> ConduitParser a m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ConduitParser a m ())
-> (s -> m ()) -> s -> ConduitParser a m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m ()
forall s (m :: * -> *). HasState s m => s -> m ()
put

runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
runSession SessionContext
context SessionState
state (Session ConduitParser
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  a
session) = ReaderT SessionContext IO (a, SessionState)
-> SessionContext -> IO (a, SessionState)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (StateT SessionState (ReaderT SessionContext IO) a
-> SessionState -> ReaderT SessionContext IO (a, SessionState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT SessionState (ReaderT SessionContext IO) a
conduit SessionState
state) SessionContext
context
  where
    conduit :: StateT SessionState (ReaderT SessionContext IO) a
conduit = ConduitT
  () Void (StateT SessionState (ReaderT SessionContext IO)) a
-> StateT SessionState (ReaderT SessionContext IO) a
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT
   () Void (StateT SessionState (ReaderT SessionContext IO)) a
 -> StateT SessionState (ReaderT SessionContext IO) a)
-> ConduitT
     () Void (StateT SessionState (ReaderT SessionContext IO)) a
-> StateT SessionState (ReaderT SessionContext IO) a
forall a b. (a -> b) -> a -> b
$ ConduitT
  ()
  SessionMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
forall i b.
ConduitT
  i
  SessionMessage
  (StateT SessionState (ReaderT SessionContext IO))
  b
chanSource ConduitT
  ()
  SessionMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
-> ConduitM
     SessionMessage
     Void
     (StateT SessionState (ReaderT SessionContext IO))
     a
-> ConduitT
     () Void (StateT SessionState (ReaderT SessionContext IO)) a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM
  SessionMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
watchdog ConduitM
  SessionMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
-> ConduitM
     FromServerMessage
     Void
     (StateT SessionState (ReaderT SessionContext IO))
     a
-> ConduitM
     SessionMessage
     Void
     (StateT SessionState (ReaderT SessionContext IO))
     a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM
  FromServerMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
updateStateC ConduitM
  FromServerMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
-> ConduitM
     FromServerMessage
     Void
     (StateT SessionState (ReaderT SessionContext IO))
     a
-> ConduitM
     FromServerMessage
     Void
     (StateT SessionState (ReaderT SessionContext IO))
     a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitParser
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  a
-> ConduitM
     FromServerMessage
     Void
     (StateT SessionState (ReaderT SessionContext IO))
     a
forall (m :: * -> *) i a.
MonadThrow m =>
ConduitParser i m a -> ConduitT i Void m a
runConduitParser (ConduitParser
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  a
-> (ConduitParserException
    -> ConduitParser
         FromServerMessage
         (StateT SessionState (ReaderT SessionContext IO))
         a)
-> ConduitParser
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ConduitParser
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  a
session ConduitParserException
-> ConduitParser
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     a
forall (m :: * -> *) i b.
(HasState SessionState m, MonadIO m) =>
ConduitParserException -> ConduitParser i m b
handler)

    handler :: ConduitParserException -> ConduitParser i m b
handler (Unexpected Text
"ConduitParser.empty") = do
      FromServerMessage
lastMsg <- Maybe FromServerMessage -> FromServerMessage
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe FromServerMessage -> FromServerMessage)
-> (SessionState -> Maybe FromServerMessage)
-> SessionState
-> FromServerMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionState -> Maybe FromServerMessage
lastReceivedMessage (SessionState -> FromServerMessage)
-> ConduitParser i m SessionState
-> ConduitParser i m FromServerMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitParser i m SessionState
forall s (m :: * -> *). HasState s m => m s
get
      Text
name <- ConduitParser i m Text
forall i (m :: * -> *). ConduitParser i m Text
getParserName
      IO b -> ConduitParser i m b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> ConduitParser i m b) -> IO b -> ConduitParser i m b
forall a b. (a -> b) -> a -> b
$ SessionException -> IO b
forall a e. Exception e => e -> a
throw (String -> FromServerMessage -> SessionException
UnexpectedMessage (Text -> String
T.unpack Text
name) FromServerMessage
lastMsg)

    handler ConduitParserException
e = ConduitParserException -> ConduitParser i m b
forall a e. Exception e => e -> a
throw ConduitParserException
e

    chanSource :: ConduitT
  i
  SessionMessage
  (StateT SessionState (ReaderT SessionContext IO))
  b
chanSource = do
      SessionMessage
msg <- IO SessionMessage
-> ConduitT
     i
     SessionMessage
     (StateT SessionState (ReaderT SessionContext IO))
     SessionMessage
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SessionMessage
 -> ConduitT
      i
      SessionMessage
      (StateT SessionState (ReaderT SessionContext IO))
      SessionMessage)
-> IO SessionMessage
-> ConduitT
     i
     SessionMessage
     (StateT SessionState (ReaderT SessionContext IO))
     SessionMessage
forall a b. (a -> b) -> a -> b
$ Chan SessionMessage -> IO SessionMessage
forall a. Chan a -> IO a
readChan (SessionContext -> Chan SessionMessage
messageChan SessionContext
context)
      Bool
-> ConduitT
     i
     SessionMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
-> ConduitT
     i
     SessionMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SessionConfig -> Bool
ignoreLogNotifications (SessionContext -> SessionConfig
config SessionContext
context) Bool -> Bool -> Bool
&& SessionMessage -> Bool
isLogNotification SessionMessage
msg) (ConduitT
   i
   SessionMessage
   (StateT SessionState (ReaderT SessionContext IO))
   ()
 -> ConduitT
      i
      SessionMessage
      (StateT SessionState (ReaderT SessionContext IO))
      ())
-> ConduitT
     i
     SessionMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
-> ConduitT
     i
     SessionMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall a b. (a -> b) -> a -> b
$
        SessionMessage
-> ConduitT
     i
     SessionMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield SessionMessage
msg
      ConduitT
  i
  SessionMessage
  (StateT SessionState (ReaderT SessionContext IO))
  b
chanSource

    isLogNotification :: SessionMessage -> Bool
isLogNotification (ServerMessage (NotShowMessage ShowMessageNotification
_)) = Bool
True
    isLogNotification (ServerMessage (NotLogMessage LogMessageNotification
_)) = Bool
True
    isLogNotification SessionMessage
_ = Bool
False

    watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
    watchdog :: ConduitM
  SessionMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
watchdog = (SessionMessage
 -> ConduitM
      SessionMessage
      FromServerMessage
      (StateT SessionState (ReaderT SessionContext IO))
      ())
-> ConduitM
     SessionMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
Conduit.awaitForever ((SessionMessage
  -> ConduitM
       SessionMessage
       FromServerMessage
       (StateT SessionState (ReaderT SessionContext IO))
       ())
 -> ConduitM
      SessionMessage
      FromServerMessage
      (StateT SessionState (ReaderT SessionContext IO))
      ())
-> (SessionMessage
    -> ConduitM
         SessionMessage
         FromServerMessage
         (StateT SessionState (ReaderT SessionContext IO))
         ())
-> ConduitM
     SessionMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall a b. (a -> b) -> a -> b
$ \SessionMessage
msg -> do
      Int
curId <- ConduitT
  SessionMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  Int
forall (m :: * -> *).
(HasReader SessionContext m, MonadIO m) =>
m Int
getCurTimeoutId
      case SessionMessage
msg of
        ServerMessage FromServerMessage
sMsg -> FromServerMessage
-> ConduitM
     SessionMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield FromServerMessage
sMsg
        TimeoutMessage Int
tId -> Bool
-> ConduitM
     SessionMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
-> ConduitM
     SessionMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
curId Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tId) (ConduitM
   SessionMessage
   FromServerMessage
   (StateT SessionState (ReaderT SessionContext IO))
   ()
 -> ConduitM
      SessionMessage
      FromServerMessage
      (StateT SessionState (ReaderT SessionContext IO))
      ())
-> ConduitM
     SessionMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
-> ConduitM
     SessionMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall a b. (a -> b) -> a -> b
$ SessionState -> Maybe FromServerMessage
lastReceivedMessage (SessionState -> Maybe FromServerMessage)
-> ConduitT
     SessionMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     SessionState
-> ConduitT
     SessionMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     (Maybe FromServerMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT
  SessionMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  SessionState
forall s (m :: * -> *). HasState s m => m s
get ConduitT
  SessionMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  (Maybe FromServerMessage)
-> (Maybe FromServerMessage
    -> ConduitM
         SessionMessage
         FromServerMessage
         (StateT SessionState (ReaderT SessionContext IO))
         ())
-> ConduitM
     SessionMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SessionException
-> ConduitM
     SessionMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall a e. Exception e => e -> a
throw (SessionException
 -> ConduitM
      SessionMessage
      FromServerMessage
      (StateT SessionState (ReaderT SessionContext IO))
      ())
-> (Maybe FromServerMessage -> SessionException)
-> Maybe FromServerMessage
-> ConduitM
     SessionMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FromServerMessage -> SessionException
Timeout

-- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
-- 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 the Server properly
                      -> Session a
                      -> IO a
runSessionWithHandles :: Handle
-> Handle
-> ProcessHandle
-> (Handle -> SessionContext -> IO ())
-> SessionConfig
-> ClientCapabilities
-> String
-> Session ()
-> Session a
-> IO a
runSessionWithHandles Handle
serverIn Handle
serverOut ProcessHandle
serverProc Handle -> SessionContext -> IO ()
serverHandler SessionConfig
config ClientCapabilities
caps String
rootDir Session ()
exitServer Session a
session = do
  String
absRootDir <- String -> IO String
canonicalizePath String
rootDir

  Handle -> BufferMode -> IO ()
hSetBuffering Handle
serverIn  BufferMode
NoBuffering
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
serverOut BufferMode
NoBuffering
  -- This is required to make sure that we don’t get any
  -- newline conversion or weird encoding issues.
  Handle -> Bool -> IO ()
hSetBinaryMode Handle
serverIn Bool
True
  Handle -> Bool -> IO ()
hSetBinaryMode Handle
serverOut Bool
True

  MVar RequestMap
reqMap <- RequestMap -> IO (MVar RequestMap)
forall a. a -> IO (MVar a)
newMVar RequestMap
newRequestMap
  Chan SessionMessage
messageChan <- IO (Chan SessionMessage)
forall a. IO (Chan a)
newChan
  MVar Int
timeoutIdVar <- Int -> IO (MVar Int)
forall a. a -> IO (MVar a)
newMVar Int
0
  MVar InitializeResponse
initRsp <- IO (MVar InitializeResponse)
forall a. IO (MVar a)
newEmptyMVar

  ThreadId
mainThreadId <- IO ThreadId
myThreadId

  let context :: SessionContext
context = Handle
-> String
-> Chan SessionMessage
-> MVar Int
-> MVar RequestMap
-> MVar InitializeResponse
-> SessionConfig
-> ClientCapabilities
-> SessionContext
SessionContext Handle
serverIn String
absRootDir Chan SessionMessage
messageChan MVar Int
timeoutIdVar MVar RequestMap
reqMap MVar InitializeResponse
initRsp SessionConfig
config ClientCapabilities
caps
      initState :: VFS -> SessionState
initState VFS
vfs = LspId
-> VFS
-> Map NormalizedUri [Diagnostic]
-> Bool
-> Maybe FromServerMessage
-> Map Text Registration
-> Set ProgressToken
-> SessionState
SessionState (Int -> LspId
IdInt Int
0) VFS
vfs Map NormalizedUri [Diagnostic]
forall a. Monoid a => a
mempty Bool
False Maybe FromServerMessage
forall a. Maybe a
Nothing Map Text Registration
forall a. Monoid a => a
mempty Set ProgressToken
forall a. Monoid a => a
mempty
      runSession' :: Session a -> IO (a, SessionState)
runSession' Session a
ses = (VFS -> IO (a, SessionState)) -> IO (a, SessionState)
forall r. (VFS -> IO r) -> IO r
initVFS ((VFS -> IO (a, SessionState)) -> IO (a, SessionState))
-> (VFS -> IO (a, SessionState)) -> IO (a, SessionState)
forall a b. (a -> b) -> a -> b
$ \VFS
vfs -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
forall a.
SessionContext -> SessionState -> Session a -> IO (a, SessionState)
runSession SessionContext
context (VFS -> SessionState
initState VFS
vfs) Session a
ses

      errorHandler :: SessionException -> IO ()
errorHandler = ThreadId -> SessionException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
mainThreadId :: SessionException -> IO ()
      serverListenerLauncher :: IO ThreadId
serverListenerLauncher =
        IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> (SessionException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Handle -> SessionContext -> IO ()
serverHandler Handle
serverOut SessionContext
context) SessionException -> IO ()
errorHandler
      server :: (Maybe Handle, Maybe Handle, Maybe a, ProcessHandle)
server = (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
serverIn, Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
serverOut, Maybe a
forall a. Maybe a
Nothing, ProcessHandle
serverProc)
      msgTimeoutMs :: Int
msgTimeoutMs = SessionConfig -> Int
messageTimeout SessionConfig
config Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10Int -> Integer -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
6
      serverAndListenerFinalizer :: ThreadId -> IO (Maybe ((), SessionState))
serverAndListenerFinalizer ThreadId
tid = do
        IO (Maybe ((), SessionState))
-> IO () -> IO (Maybe ((), SessionState))
forall a b. IO a -> IO b -> IO a
finally (Int -> IO ((), SessionState) -> IO (Maybe ((), SessionState))
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
msgTimeoutMs (Session () -> IO ((), SessionState)
forall a. Session a -> IO (a, SessionState)
runSession' Session ()
exitServer)) (IO () -> IO (Maybe ((), SessionState)))
-> IO () -> IO (Maybe ((), SessionState))
forall a b. (a -> b) -> a -> b
$ do
          -- Make sure to kill the listener first, before closing
          -- handles etc via cleanupProcess
          ThreadId -> IO ()
killThread ThreadId
tid
          -- Give the server some time to exit cleanly
          -- It makes the server hangs in windows so we have to avoid it
#ifndef mingw32_HOST_OS
          Int -> IO ExitCode -> IO (Maybe ExitCode)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
msgTimeoutMs (ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
serverProc)
#endif
          (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
cleanupProcess (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. (Maybe Handle, Maybe Handle, Maybe a, ProcessHandle)
server

  (a
result, SessionState
_) <- IO ThreadId
-> (ThreadId -> IO (Maybe ((), SessionState)))
-> (ThreadId -> IO (a, SessionState))
-> IO (a, SessionState)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO ThreadId
serverListenerLauncher
                         ThreadId -> IO (Maybe ((), SessionState))
serverAndListenerFinalizer
                         (IO (a, SessionState) -> ThreadId -> IO (a, SessionState)
forall a b. a -> b -> a
const (IO (a, SessionState) -> ThreadId -> IO (a, SessionState))
-> IO (a, SessionState) -> ThreadId -> IO (a, SessionState)
forall a b. (a -> b) -> a -> b
$ Session a -> IO (a, SessionState)
forall a. Session a -> IO (a, SessionState)
runSession' Session a
session)
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
updateStateC :: ConduitM
  FromServerMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
updateStateC = (FromServerMessage
 -> ConduitM
      FromServerMessage
      FromServerMessage
      (StateT SessionState (ReaderT SessionContext IO))
      ())
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever ((FromServerMessage
  -> ConduitM
       FromServerMessage
       FromServerMessage
       (StateT SessionState (ReaderT SessionContext IO))
       ())
 -> ConduitM
      FromServerMessage
      FromServerMessage
      (StateT SessionState (ReaderT SessionContext IO))
      ())
-> (FromServerMessage
    -> ConduitM
         FromServerMessage
         FromServerMessage
         (StateT SessionState (ReaderT SessionContext IO))
         ())
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall a b. (a -> b) -> a -> b
$ \FromServerMessage
msg -> do
  FromServerMessage
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (m :: * -> *).
(MonadIO m, HasReader SessionContext m, HasState SessionState m) =>
FromServerMessage -> m ()
updateState FromServerMessage
msg
  FromServerMessage
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield FromServerMessage
msg

updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
            => FromServerMessage -> m ()
updateState :: FromServerMessage -> m ()
updateState (NotWorkDoneProgressBegin WorkDoneProgressBeginNotification
req) =
  (SessionState -> SessionState) -> m ()
forall s (m :: * -> *). HasState s m => (s -> s) -> m ()
modify ((SessionState -> SessionState) -> m ())
-> (SessionState -> SessionState) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionState
s -> SessionState
s { curProgressSessions :: Set ProgressToken
curProgressSessions = ProgressToken -> Set ProgressToken -> Set ProgressToken
forall a. Ord a => a -> Set a -> Set a
Set.insert (WorkDoneProgressBeginNotification
req WorkDoneProgressBeginNotification
-> Getting
     ProgressToken WorkDoneProgressBeginNotification ProgressToken
-> ProgressToken
forall s a. s -> Getting a s a -> a
^. (ProgressParams WorkDoneProgressBeginParams
 -> Const
      ProgressToken (ProgressParams WorkDoneProgressBeginParams))
-> WorkDoneProgressBeginNotification
-> Const ProgressToken WorkDoneProgressBeginNotification
forall s a. HasParams s a => Lens' s a
params ((ProgressParams WorkDoneProgressBeginParams
  -> Const
       ProgressToken (ProgressParams WorkDoneProgressBeginParams))
 -> WorkDoneProgressBeginNotification
 -> Const ProgressToken WorkDoneProgressBeginNotification)
-> ((ProgressToken -> Const ProgressToken ProgressToken)
    -> ProgressParams WorkDoneProgressBeginParams
    -> Const
         ProgressToken (ProgressParams WorkDoneProgressBeginParams))
-> Getting
     ProgressToken WorkDoneProgressBeginNotification ProgressToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgressToken -> Const ProgressToken ProgressToken)
-> ProgressParams WorkDoneProgressBeginParams
-> Const ProgressToken (ProgressParams WorkDoneProgressBeginParams)
forall s a. HasToken s a => Lens' s a
token) (Set ProgressToken -> Set ProgressToken)
-> Set ProgressToken -> Set ProgressToken
forall a b. (a -> b) -> a -> b
$ SessionState -> Set ProgressToken
curProgressSessions SessionState
s }
updateState (NotWorkDoneProgressEnd WorkDoneProgressEndNotification
req) =
  (SessionState -> SessionState) -> m ()
forall s (m :: * -> *). HasState s m => (s -> s) -> m ()
modify ((SessionState -> SessionState) -> m ())
-> (SessionState -> SessionState) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionState
s -> SessionState
s { curProgressSessions :: Set ProgressToken
curProgressSessions = ProgressToken -> Set ProgressToken -> Set ProgressToken
forall a. Ord a => a -> Set a -> Set a
Set.delete (WorkDoneProgressEndNotification
req WorkDoneProgressEndNotification
-> Getting
     ProgressToken WorkDoneProgressEndNotification ProgressToken
-> ProgressToken
forall s a. s -> Getting a s a -> a
^. (ProgressParams WorkDoneProgressEndParams
 -> Const ProgressToken (ProgressParams WorkDoneProgressEndParams))
-> WorkDoneProgressEndNotification
-> Const ProgressToken WorkDoneProgressEndNotification
forall s a. HasParams s a => Lens' s a
params ((ProgressParams WorkDoneProgressEndParams
  -> Const ProgressToken (ProgressParams WorkDoneProgressEndParams))
 -> WorkDoneProgressEndNotification
 -> Const ProgressToken WorkDoneProgressEndNotification)
-> ((ProgressToken -> Const ProgressToken ProgressToken)
    -> ProgressParams WorkDoneProgressEndParams
    -> Const ProgressToken (ProgressParams WorkDoneProgressEndParams))
-> Getting
     ProgressToken WorkDoneProgressEndNotification ProgressToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgressToken -> Const ProgressToken ProgressToken)
-> ProgressParams WorkDoneProgressEndParams
-> Const ProgressToken (ProgressParams WorkDoneProgressEndParams)
forall s a. HasToken s a => Lens' s a
token) (Set ProgressToken -> Set ProgressToken)
-> Set ProgressToken -> Set ProgressToken
forall a b. (a -> b) -> a -> b
$ SessionState -> Set ProgressToken
curProgressSessions SessionState
s }

-- Keep track of dynamic capability registration
updateState (ReqRegisterCapability RegisterCapabilityRequest
req) = do
  let List [(Text, Registration)]
newRegs = (\Registration
r -> (Registration
r Registration -> Getting Text Registration Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Registration Text
forall s a. HasId s a => Lens' s a
LSP.id, Registration
r)) (Registration -> (Text, Registration))
-> List Registration -> List (Text, Registration)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RegisterCapabilityRequest
req RegisterCapabilityRequest
-> Getting
     (List Registration) RegisterCapabilityRequest (List Registration)
-> List Registration
forall s a. s -> Getting a s a -> a
^. (RegistrationParams
 -> Const (List Registration) RegistrationParams)
-> RegisterCapabilityRequest
-> Const (List Registration) RegisterCapabilityRequest
forall s a. HasParams s a => Lens' s a
params ((RegistrationParams
  -> Const (List Registration) RegistrationParams)
 -> RegisterCapabilityRequest
 -> Const (List Registration) RegisterCapabilityRequest)
-> ((List Registration
     -> Const (List Registration) (List Registration))
    -> RegistrationParams
    -> Const (List Registration) RegistrationParams)
-> Getting
     (List Registration) RegisterCapabilityRequest (List Registration)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (List Registration
 -> Const (List Registration) (List Registration))
-> RegistrationParams
-> Const (List Registration) RegistrationParams
forall s a. HasRegistrations s a => Lens' s a
registrations
  (SessionState -> SessionState) -> m ()
forall s (m :: * -> *). HasState s m => (s -> s) -> m ()
modify ((SessionState -> SessionState) -> m ())
-> (SessionState -> SessionState) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionState
s ->
    SessionState
s { curDynCaps :: Map Text Registration
curDynCaps = Map Text Registration
-> Map Text Registration -> Map Text Registration
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ([(Text, Registration)] -> Map Text Registration
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Registration)]
newRegs) (SessionState -> Map Text Registration
curDynCaps SessionState
s) }

updateState (ReqUnregisterCapability UnregisterCapabilityRequest
req) = do
  let List [Text]
unRegs = (Unregistration -> Getting Text Unregistration Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Unregistration Text
forall s a. HasId s a => Lens' s a
LSP.id) (Unregistration -> Text) -> List Unregistration -> List Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnregisterCapabilityRequest
req UnregisterCapabilityRequest
-> Getting
     (List Unregistration)
     UnregisterCapabilityRequest
     (List Unregistration)
-> List Unregistration
forall s a. s -> Getting a s a -> a
^. (UnregistrationParams
 -> Const (List Unregistration) UnregistrationParams)
-> UnregisterCapabilityRequest
-> Const (List Unregistration) UnregisterCapabilityRequest
forall s a. HasParams s a => Lens' s a
params ((UnregistrationParams
  -> Const (List Unregistration) UnregistrationParams)
 -> UnregisterCapabilityRequest
 -> Const (List Unregistration) UnregisterCapabilityRequest)
-> ((List Unregistration
     -> Const (List Unregistration) (List Unregistration))
    -> UnregistrationParams
    -> Const (List Unregistration) UnregistrationParams)
-> Getting
     (List Unregistration)
     UnregisterCapabilityRequest
     (List Unregistration)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (List Unregistration
 -> Const (List Unregistration) (List Unregistration))
-> UnregistrationParams
-> Const (List Unregistration) UnregistrationParams
forall s a. HasUnregistrations s a => Lens' s a
unregistrations
  (SessionState -> SessionState) -> m ()
forall s (m :: * -> *). HasState s m => (s -> s) -> m ()
modify ((SessionState -> SessionState) -> m ())
-> (SessionState -> SessionState) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionState
s ->
    let newCurDynCaps :: Map Text Registration
newCurDynCaps = (Text -> Map Text Registration -> Map Text Registration)
-> Map Text Registration -> [Text] -> Map Text Registration
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' Text -> Map Text Registration -> Map Text Registration
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (SessionState -> Map Text Registration
curDynCaps SessionState
s) [Text]
unRegs
    in SessionState
s { curDynCaps :: Map Text Registration
curDynCaps = Map Text Registration
newCurDynCaps }

updateState (NotPublishDiagnostics PublishDiagnosticsNotification
n) = do
  let List [Diagnostic]
diags = PublishDiagnosticsNotification
n PublishDiagnosticsNotification
-> Getting
     (List Diagnostic) PublishDiagnosticsNotification (List Diagnostic)
-> List Diagnostic
forall s a. s -> Getting a s a -> a
^. (PublishDiagnosticsParams
 -> Const (List Diagnostic) PublishDiagnosticsParams)
-> PublishDiagnosticsNotification
-> Const (List Diagnostic) PublishDiagnosticsNotification
forall s a. HasParams s a => Lens' s a
params ((PublishDiagnosticsParams
  -> Const (List Diagnostic) PublishDiagnosticsParams)
 -> PublishDiagnosticsNotification
 -> Const (List Diagnostic) PublishDiagnosticsNotification)
-> ((List Diagnostic -> Const (List Diagnostic) (List Diagnostic))
    -> PublishDiagnosticsParams
    -> Const (List Diagnostic) PublishDiagnosticsParams)
-> Getting
     (List Diagnostic) PublishDiagnosticsNotification (List Diagnostic)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (List Diagnostic -> Const (List Diagnostic) (List Diagnostic))
-> PublishDiagnosticsParams
-> Const (List Diagnostic) PublishDiagnosticsParams
forall s a. HasDiagnostics s a => Lens' s a
diagnostics
      doc :: Uri
doc = PublishDiagnosticsNotification
n PublishDiagnosticsNotification
-> Getting Uri PublishDiagnosticsNotification Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
-> PublishDiagnosticsNotification
-> Const Uri PublishDiagnosticsNotification
forall s a. HasParams s a => Lens' s a
params ((PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
 -> PublishDiagnosticsNotification
 -> Const Uri PublishDiagnosticsNotification)
-> ((Uri -> Const Uri Uri)
    -> PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
-> Getting Uri PublishDiagnosticsNotification Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams
forall s a. HasUri s a => Lens' s a
uri
  (SessionState -> SessionState) -> m ()
forall s (m :: * -> *). HasState s m => (s -> s) -> m ()
modify ((SessionState -> SessionState) -> m ())
-> (SessionState -> SessionState) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionState
s ->
    let newDiags :: Map NormalizedUri [Diagnostic]
newDiags = NormalizedUri
-> [Diagnostic]
-> Map NormalizedUri [Diagnostic]
-> Map NormalizedUri [Diagnostic]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Uri -> NormalizedUri
toNormalizedUri Uri
doc) [Diagnostic]
diags (SessionState -> Map NormalizedUri [Diagnostic]
curDiagnostics SessionState
s)
      in SessionState
s { curDiagnostics :: Map NormalizedUri [Diagnostic]
curDiagnostics = Map NormalizedUri [Diagnostic]
newDiags }

updateState (ReqApplyWorkspaceEdit ApplyWorkspaceEditRequest
r) = do

  -- First, prefer the versioned documentChanges field
  [DidChangeTextDocumentParams]
allChangeParams <- case ApplyWorkspaceEditRequest
r ApplyWorkspaceEditRequest
-> Getting
     (Maybe (List TextDocumentEdit))
     ApplyWorkspaceEditRequest
     (Maybe (List TextDocumentEdit))
-> Maybe (List TextDocumentEdit)
forall s a. s -> Getting a s a -> a
^. (ApplyWorkspaceEditParams
 -> Const (Maybe (List TextDocumentEdit)) ApplyWorkspaceEditParams)
-> ApplyWorkspaceEditRequest
-> Const (Maybe (List TextDocumentEdit)) ApplyWorkspaceEditRequest
forall s a. HasParams s a => Lens' s a
params ((ApplyWorkspaceEditParams
  -> Const (Maybe (List TextDocumentEdit)) ApplyWorkspaceEditParams)
 -> ApplyWorkspaceEditRequest
 -> Const (Maybe (List TextDocumentEdit)) ApplyWorkspaceEditRequest)
-> ((Maybe (List TextDocumentEdit)
     -> Const
          (Maybe (List TextDocumentEdit)) (Maybe (List TextDocumentEdit)))
    -> ApplyWorkspaceEditParams
    -> Const (Maybe (List TextDocumentEdit)) ApplyWorkspaceEditParams)
-> Getting
     (Maybe (List TextDocumentEdit))
     ApplyWorkspaceEditRequest
     (Maybe (List TextDocumentEdit))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WorkspaceEdit
 -> Const (Maybe (List TextDocumentEdit)) WorkspaceEdit)
-> ApplyWorkspaceEditParams
-> Const (Maybe (List TextDocumentEdit)) ApplyWorkspaceEditParams
forall s a. HasEdit s a => Lens' s a
edit ((WorkspaceEdit
  -> Const (Maybe (List TextDocumentEdit)) WorkspaceEdit)
 -> ApplyWorkspaceEditParams
 -> Const (Maybe (List TextDocumentEdit)) ApplyWorkspaceEditParams)
-> ((Maybe (List TextDocumentEdit)
     -> Const
          (Maybe (List TextDocumentEdit)) (Maybe (List TextDocumentEdit)))
    -> WorkspaceEdit
    -> Const (Maybe (List TextDocumentEdit)) WorkspaceEdit)
-> (Maybe (List TextDocumentEdit)
    -> Const
         (Maybe (List TextDocumentEdit)) (Maybe (List TextDocumentEdit)))
-> ApplyWorkspaceEditParams
-> Const (Maybe (List TextDocumentEdit)) ApplyWorkspaceEditParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (List TextDocumentEdit)
 -> Const
      (Maybe (List TextDocumentEdit)) (Maybe (List TextDocumentEdit)))
-> WorkspaceEdit
-> Const (Maybe (List TextDocumentEdit)) WorkspaceEdit
forall s a. HasDocumentChanges s a => Lens' s a
documentChanges of
    Just (List [TextDocumentEdit]
cs) -> do
      (TextDocumentEdit -> m ()) -> [TextDocumentEdit] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Uri -> m ()
forall (m :: * -> *).
(HasState SessionState m, HasReader SessionContext m, MonadIO m) =>
Uri -> m ()
checkIfNeedsOpened (Uri -> m ())
-> (TextDocumentEdit -> Uri) -> TextDocumentEdit -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentEdit -> Getting Uri TextDocumentEdit Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (VersionedTextDocumentIdentifier
 -> Const Uri VersionedTextDocumentIdentifier)
-> TextDocumentEdit -> Const Uri TextDocumentEdit
forall s a. HasTextDocument s a => Lens' s a
textDocument ((VersionedTextDocumentIdentifier
  -> Const Uri VersionedTextDocumentIdentifier)
 -> TextDocumentEdit -> Const Uri TextDocumentEdit)
-> ((Uri -> Const Uri Uri)
    -> VersionedTextDocumentIdentifier
    -> Const Uri VersionedTextDocumentIdentifier)
-> Getting Uri TextDocumentEdit Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> VersionedTextDocumentIdentifier
-> Const Uri VersionedTextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
uri)) [TextDocumentEdit]
cs
      [DidChangeTextDocumentParams] -> m [DidChangeTextDocumentParams]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DidChangeTextDocumentParams] -> m [DidChangeTextDocumentParams])
-> [DidChangeTextDocumentParams] -> m [DidChangeTextDocumentParams]
forall a b. (a -> b) -> a -> b
$ (TextDocumentEdit -> DidChangeTextDocumentParams)
-> [TextDocumentEdit] -> [DidChangeTextDocumentParams]
forall a b. (a -> b) -> [a] -> [b]
map TextDocumentEdit -> DidChangeTextDocumentParams
getParams [TextDocumentEdit]
cs
    -- Then fall back to the changes field
    Maybe (List TextDocumentEdit)
Nothing -> case ApplyWorkspaceEditRequest
r ApplyWorkspaceEditRequest
-> Getting
     (Maybe (HashMap Uri (List TextEdit)))
     ApplyWorkspaceEditRequest
     (Maybe (HashMap Uri (List TextEdit)))
-> Maybe (HashMap Uri (List TextEdit))
forall s a. s -> Getting a s a -> a
^. (ApplyWorkspaceEditParams
 -> Const
      (Maybe (HashMap Uri (List TextEdit))) ApplyWorkspaceEditParams)
-> ApplyWorkspaceEditRequest
-> Const
     (Maybe (HashMap Uri (List TextEdit))) ApplyWorkspaceEditRequest
forall s a. HasParams s a => Lens' s a
params ((ApplyWorkspaceEditParams
  -> Const
       (Maybe (HashMap Uri (List TextEdit))) ApplyWorkspaceEditParams)
 -> ApplyWorkspaceEditRequest
 -> Const
      (Maybe (HashMap Uri (List TextEdit))) ApplyWorkspaceEditRequest)
-> ((Maybe (HashMap Uri (List TextEdit))
     -> Const
          (Maybe (HashMap Uri (List TextEdit)))
          (Maybe (HashMap Uri (List TextEdit))))
    -> ApplyWorkspaceEditParams
    -> Const
         (Maybe (HashMap Uri (List TextEdit))) ApplyWorkspaceEditParams)
-> Getting
     (Maybe (HashMap Uri (List TextEdit)))
     ApplyWorkspaceEditRequest
     (Maybe (HashMap Uri (List TextEdit)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WorkspaceEdit
 -> Const (Maybe (HashMap Uri (List TextEdit))) WorkspaceEdit)
-> ApplyWorkspaceEditParams
-> Const
     (Maybe (HashMap Uri (List TextEdit))) ApplyWorkspaceEditParams
forall s a. HasEdit s a => Lens' s a
edit ((WorkspaceEdit
  -> Const (Maybe (HashMap Uri (List TextEdit))) WorkspaceEdit)
 -> ApplyWorkspaceEditParams
 -> Const
      (Maybe (HashMap Uri (List TextEdit))) ApplyWorkspaceEditParams)
-> ((Maybe (HashMap Uri (List TextEdit))
     -> Const
          (Maybe (HashMap Uri (List TextEdit)))
          (Maybe (HashMap Uri (List TextEdit))))
    -> WorkspaceEdit
    -> Const (Maybe (HashMap Uri (List TextEdit))) WorkspaceEdit)
-> (Maybe (HashMap Uri (List TextEdit))
    -> Const
         (Maybe (HashMap Uri (List TextEdit)))
         (Maybe (HashMap Uri (List TextEdit))))
-> ApplyWorkspaceEditParams
-> Const
     (Maybe (HashMap Uri (List TextEdit))) ApplyWorkspaceEditParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (HashMap Uri (List TextEdit))
 -> Const
      (Maybe (HashMap Uri (List TextEdit)))
      (Maybe (HashMap Uri (List TextEdit))))
-> WorkspaceEdit
-> Const (Maybe (HashMap Uri (List TextEdit))) WorkspaceEdit
forall s a. HasChanges s a => Lens' s a
changes of
      Just HashMap Uri (List TextEdit)
cs -> do
        (Uri -> m ()) -> [Uri] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Uri -> m ()
forall (m :: * -> *).
(HasState SessionState m, HasReader SessionContext m, MonadIO m) =>
Uri -> m ()
checkIfNeedsOpened (HashMap Uri (List TextEdit) -> [Uri]
forall k v. HashMap k v -> [k]
HashMap.keys HashMap Uri (List TextEdit)
cs)
        [[DidChangeTextDocumentParams]] -> [DidChangeTextDocumentParams]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[DidChangeTextDocumentParams]] -> [DidChangeTextDocumentParams])
-> m [[DidChangeTextDocumentParams]]
-> m [DidChangeTextDocumentParams]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Uri, List TextEdit) -> m [DidChangeTextDocumentParams])
-> [(Uri, List TextEdit)] -> m [[DidChangeTextDocumentParams]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Uri -> List TextEdit -> m [DidChangeTextDocumentParams])
-> (Uri, List TextEdit) -> m [DidChangeTextDocumentParams]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Uri -> List TextEdit -> m [DidChangeTextDocumentParams]
forall (f :: * -> *).
HasState SessionState f =>
Uri -> List TextEdit -> f [DidChangeTextDocumentParams]
getChangeParams) (HashMap Uri (List TextEdit) -> [(Uri, List TextEdit)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Uri (List TextEdit)
cs)
      Maybe (HashMap Uri (List TextEdit))
Nothing ->
        String -> m [DidChangeTextDocumentParams]
forall a. HasCallStack => String -> a
error String
"WorkspaceEdit contains neither documentChanges nor changes!"

  (SessionState -> m SessionState) -> m ()
forall s (m :: * -> *).
(HasState s m, HasState s m, Monad m) =>
(s -> m s) -> m ()
modifyM ((SessionState -> m SessionState) -> m ())
-> (SessionState -> m SessionState) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionState
s -> do
    VFS
newVFS <- IO VFS -> m VFS
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO VFS -> m VFS) -> IO VFS -> m VFS
forall a b. (a -> b) -> a -> b
$ VFS -> ApplyWorkspaceEditRequest -> IO VFS
changeFromServerVFS (SessionState -> VFS
vfs SessionState
s) ApplyWorkspaceEditRequest
r
    SessionState -> m SessionState
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionState -> m SessionState) -> SessionState -> m SessionState
forall a b. (a -> b) -> a -> b
$ SessionState
s { vfs :: VFS
vfs = VFS
newVFS }

  let groupedParams :: [[DidChangeTextDocumentParams]]
groupedParams = (DidChangeTextDocumentParams
 -> DidChangeTextDocumentParams -> Bool)
-> [DidChangeTextDocumentParams] -> [[DidChangeTextDocumentParams]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\DidChangeTextDocumentParams
a DidChangeTextDocumentParams
b -> DidChangeTextDocumentParams
a DidChangeTextDocumentParams
-> Getting
     VersionedTextDocumentIdentifier
     DidChangeTextDocumentParams
     VersionedTextDocumentIdentifier
-> VersionedTextDocumentIdentifier
forall s a. s -> Getting a s a -> a
^. Getting
  VersionedTextDocumentIdentifier
  DidChangeTextDocumentParams
  VersionedTextDocumentIdentifier
forall s a. HasTextDocument s a => Lens' s a
textDocument VersionedTextDocumentIdentifier
-> VersionedTextDocumentIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
== DidChangeTextDocumentParams
b DidChangeTextDocumentParams
-> Getting
     VersionedTextDocumentIdentifier
     DidChangeTextDocumentParams
     VersionedTextDocumentIdentifier
-> VersionedTextDocumentIdentifier
forall s a. s -> Getting a s a -> a
^. Getting
  VersionedTextDocumentIdentifier
  DidChangeTextDocumentParams
  VersionedTextDocumentIdentifier
forall s a. HasTextDocument s a => Lens' s a
textDocument) [DidChangeTextDocumentParams]
allChangeParams
      mergedParams :: [DidChangeTextDocumentParams]
mergedParams = ([DidChangeTextDocumentParams] -> DidChangeTextDocumentParams)
-> [[DidChangeTextDocumentParams]] -> [DidChangeTextDocumentParams]
forall a b. (a -> b) -> [a] -> [b]
map [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
mergeParams [[DidChangeTextDocumentParams]]
groupedParams

  -- TODO: Don't do this when replaying a session
  [DidChangeTextDocumentParams]
-> (DidChangeTextDocumentParams -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DidChangeTextDocumentParams]
mergedParams (NotificationMessage ClientMethod DidChangeTextDocumentParams
-> m ()
forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage (NotificationMessage ClientMethod DidChangeTextDocumentParams
 -> m ())
-> (DidChangeTextDocumentParams
    -> NotificationMessage ClientMethod DidChangeTextDocumentParams)
-> DidChangeTextDocumentParams
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> ClientMethod
-> DidChangeTextDocumentParams
-> NotificationMessage ClientMethod DidChangeTextDocumentParams
forall m a. Text -> m -> a -> NotificationMessage m a
NotificationMessage Text
"2.0" ClientMethod
TextDocumentDidChange)

  -- Update VFS to new document versions
  let sortedVersions :: [[DidChangeTextDocumentParams]]
sortedVersions = ([DidChangeTextDocumentParams] -> [DidChangeTextDocumentParams])
-> [[DidChangeTextDocumentParams]]
-> [[DidChangeTextDocumentParams]]
forall a b. (a -> b) -> [a] -> [b]
map ((DidChangeTextDocumentParams
 -> DidChangeTextDocumentParams -> Ordering)
-> [DidChangeTextDocumentParams] -> [DidChangeTextDocumentParams]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (TextDocumentVersion -> TextDocumentVersion -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (TextDocumentVersion -> TextDocumentVersion -> Ordering)
-> (DidChangeTextDocumentParams -> TextDocumentVersion)
-> DidChangeTextDocumentParams
-> DidChangeTextDocumentParams
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (DidChangeTextDocumentParams
-> Getting
     TextDocumentVersion DidChangeTextDocumentParams TextDocumentVersion
-> TextDocumentVersion
forall s a. s -> Getting a s a -> a
^. (VersionedTextDocumentIdentifier
 -> Const TextDocumentVersion VersionedTextDocumentIdentifier)
-> DidChangeTextDocumentParams
-> Const TextDocumentVersion DidChangeTextDocumentParams
forall s a. HasTextDocument s a => Lens' s a
textDocument ((VersionedTextDocumentIdentifier
  -> Const TextDocumentVersion VersionedTextDocumentIdentifier)
 -> DidChangeTextDocumentParams
 -> Const TextDocumentVersion DidChangeTextDocumentParams)
-> ((TextDocumentVersion
     -> Const TextDocumentVersion TextDocumentVersion)
    -> VersionedTextDocumentIdentifier
    -> Const TextDocumentVersion VersionedTextDocumentIdentifier)
-> Getting
     TextDocumentVersion DidChangeTextDocumentParams TextDocumentVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentVersion
 -> Const TextDocumentVersion TextDocumentVersion)
-> VersionedTextDocumentIdentifier
-> Const TextDocumentVersion VersionedTextDocumentIdentifier
forall s a. HasVersion s a => Lens' s a
version))) [[DidChangeTextDocumentParams]]
groupedParams
      latestVersions :: [VersionedTextDocumentIdentifier]
latestVersions = ([DidChangeTextDocumentParams] -> VersionedTextDocumentIdentifier)
-> [[DidChangeTextDocumentParams]]
-> [VersionedTextDocumentIdentifier]
forall a b. (a -> b) -> [a] -> [b]
map ((DidChangeTextDocumentParams
-> Getting
     VersionedTextDocumentIdentifier
     DidChangeTextDocumentParams
     VersionedTextDocumentIdentifier
-> VersionedTextDocumentIdentifier
forall s a. s -> Getting a s a -> a
^. Getting
  VersionedTextDocumentIdentifier
  DidChangeTextDocumentParams
  VersionedTextDocumentIdentifier
forall s a. HasTextDocument s a => Lens' s a
textDocument) (DidChangeTextDocumentParams -> VersionedTextDocumentIdentifier)
-> ([DidChangeTextDocumentParams] -> DidChangeTextDocumentParams)
-> [DidChangeTextDocumentParams]
-> VersionedTextDocumentIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
forall a. [a] -> a
last) [[DidChangeTextDocumentParams]]
sortedVersions
      bumpedVersions :: [VersionedTextDocumentIdentifier]
bumpedVersions = (VersionedTextDocumentIdentifier
 -> VersionedTextDocumentIdentifier)
-> [VersionedTextDocumentIdentifier]
-> [VersionedTextDocumentIdentifier]
forall a b. (a -> b) -> [a] -> [b]
map ((TextDocumentVersion -> Identity TextDocumentVersion)
-> VersionedTextDocumentIdentifier
-> Identity VersionedTextDocumentIdentifier
forall s a. HasVersion s a => Lens' s a
version ((TextDocumentVersion -> Identity TextDocumentVersion)
 -> VersionedTextDocumentIdentifier
 -> Identity VersionedTextDocumentIdentifier)
-> ((Int -> Identity Int)
    -> TextDocumentVersion -> Identity TextDocumentVersion)
-> (Int -> Identity Int)
-> VersionedTextDocumentIdentifier
-> Identity VersionedTextDocumentIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Identity Int)
-> TextDocumentVersion -> Identity TextDocumentVersion
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((Int -> Identity Int)
 -> VersionedTextDocumentIdentifier
 -> Identity VersionedTextDocumentIdentifier)
-> Int
-> VersionedTextDocumentIdentifier
-> VersionedTextDocumentIdentifier
forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Int
1) [VersionedTextDocumentIdentifier]
latestVersions

  [VersionedTextDocumentIdentifier]
-> (VersionedTextDocumentIdentifier -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [VersionedTextDocumentIdentifier]
bumpedVersions ((VersionedTextDocumentIdentifier -> m ()) -> m ())
-> (VersionedTextDocumentIdentifier -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(VersionedTextDocumentIdentifier Uri
uri TextDocumentVersion
v) ->
    (SessionState -> SessionState) -> m ()
forall s (m :: * -> *). HasState s m => (s -> s) -> m ()
modify ((SessionState -> SessionState) -> m ())
-> (SessionState -> SessionState) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionState
s ->
      let oldVFS :: VFS
oldVFS = SessionState -> VFS
vfs SessionState
s
          update :: VirtualFile -> VirtualFile
update (VirtualFile Int
oldV Int
file_ver Rope
t) = Int -> Int -> Rope -> VirtualFile
VirtualFile (Int -> TextDocumentVersion -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
oldV TextDocumentVersion
v) (Int
file_ver Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Rope
t
          newVFS :: VFS
newVFS = (VFSMap -> VFSMap) -> VFS -> VFS
updateVFS ((VirtualFile -> VirtualFile) -> NormalizedUri -> VFSMap -> VFSMap
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust VirtualFile -> VirtualFile
update (Uri -> NormalizedUri
toNormalizedUri Uri
uri)) VFS
oldVFS
      in SessionState
s { vfs :: VFS
vfs = VFS
newVFS }

  where checkIfNeedsOpened :: Uri -> m ()
checkIfNeedsOpened Uri
uri = do
          VFS
oldVFS <- SessionState -> VFS
vfs (SessionState -> VFS) -> m SessionState -> m VFS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m SessionState
forall s (m :: * -> *). HasState s m => m s
get
          SessionContext
ctx <- m SessionContext
forall r (m :: * -> *). HasReader r m => m r
ask

          -- if its not open, open it
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Uri -> NormalizedUri
toNormalizedUri Uri
uri NormalizedUri -> VFSMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` VFS -> VFSMap
vfsMap VFS
oldVFS) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            let fp :: String
fp = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Uri -> Maybe String
uriToFilePath Uri
uri
            Text
contents <- IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
T.readFile String
fp
            let item :: TextDocumentItem
item = Uri -> Text -> Int -> Text -> TextDocumentItem
TextDocumentItem (String -> Uri
filePathToUri String
fp) Text
"" Int
0 Text
contents
                msg :: NotificationMessage ClientMethod DidOpenTextDocumentParams
msg = Text
-> ClientMethod
-> DidOpenTextDocumentParams
-> NotificationMessage ClientMethod DidOpenTextDocumentParams
forall m a. Text -> m -> a -> NotificationMessage m a
NotificationMessage Text
"2.0" ClientMethod
TextDocumentDidOpen (TextDocumentItem -> DidOpenTextDocumentParams
DidOpenTextDocumentParams TextDocumentItem
item)
            IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
B.hPut (SessionContext -> Handle
serverIn SessionContext
ctx) (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
addHeader (NotificationMessage ClientMethod DidOpenTextDocumentParams
-> ByteString
forall a. ToJSON a => a -> ByteString
encode NotificationMessage ClientMethod DidOpenTextDocumentParams
msg)

            (SessionState -> m SessionState) -> m ()
forall s (m :: * -> *).
(HasState s m, HasState s m, Monad m) =>
(s -> m s) -> m ()
modifyM ((SessionState -> m SessionState) -> m ())
-> (SessionState -> m SessionState) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionState
s -> do
              let (VFS
newVFS,[String]
_) = VFS
-> NotificationMessage ClientMethod DidOpenTextDocumentParams
-> (VFS, [String])
openVFS (SessionState -> VFS
vfs SessionState
s) NotificationMessage ClientMethod DidOpenTextDocumentParams
msg
              SessionState -> m SessionState
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionState -> m SessionState) -> SessionState -> m SessionState
forall a b. (a -> b) -> a -> b
$ SessionState
s { vfs :: VFS
vfs = VFS
newVFS }

        getParams :: TextDocumentEdit -> DidChangeTextDocumentParams
getParams (TextDocumentEdit VersionedTextDocumentIdentifier
docId (List [TextEdit]
edits)) =
          let changeEvents :: [TextDocumentContentChangeEvent]
changeEvents = (TextEdit -> TextDocumentContentChangeEvent)
-> [TextEdit] -> [TextDocumentContentChangeEvent]
forall a b. (a -> b) -> [a] -> [b]
map (\TextEdit
e -> Maybe Range
-> TextDocumentVersion -> Text -> TextDocumentContentChangeEvent
TextDocumentContentChangeEvent (Range -> Maybe Range
forall a. a -> Maybe a
Just (TextEdit
e TextEdit -> Getting Range TextEdit Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range TextEdit Range
forall s a. HasRange s a => Lens' s a
range)) TextDocumentVersion
forall a. Maybe a
Nothing (TextEdit
e TextEdit -> Getting Text TextEdit Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text TextEdit Text
forall s a. HasNewText s a => Lens' s a
newText)) [TextEdit]
edits
            in VersionedTextDocumentIdentifier
-> List TextDocumentContentChangeEvent
-> DidChangeTextDocumentParams
DidChangeTextDocumentParams VersionedTextDocumentIdentifier
docId ([TextDocumentContentChangeEvent]
-> List TextDocumentContentChangeEvent
forall a. [a] -> List a
List [TextDocumentContentChangeEvent]
changeEvents)

        -- For a uri returns an infinite list of versions [n,n+1,n+2,...]
        -- where n is the current version
        textDocumentVersions :: Uri -> m [VersionedTextDocumentIdentifier]
textDocumentVersions Uri
uri = do
          VFSMap
m <- VFS -> VFSMap
vfsMap (VFS -> VFSMap) -> (SessionState -> VFS) -> SessionState -> VFSMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionState -> VFS
vfs (SessionState -> VFSMap) -> m SessionState -> m VFSMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m SessionState
forall s (m :: * -> *). HasState s m => m s
get
          let curVer :: Int
curVer = Int -> TextDocumentVersion -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (TextDocumentVersion -> Int) -> TextDocumentVersion -> Int
forall a b. (a -> b) -> a -> b
$
                VirtualFile -> Int
_lsp_version (VirtualFile -> Int) -> Maybe VirtualFile -> TextDocumentVersion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VFSMap
m VFSMap -> NormalizedUri -> Maybe VirtualFile
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? (Uri -> NormalizedUri
toNormalizedUri Uri
uri)
          [VersionedTextDocumentIdentifier]
-> m [VersionedTextDocumentIdentifier]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([VersionedTextDocumentIdentifier]
 -> m [VersionedTextDocumentIdentifier])
-> [VersionedTextDocumentIdentifier]
-> m [VersionedTextDocumentIdentifier]
forall a b. (a -> b) -> a -> b
$ (Int -> VersionedTextDocumentIdentifier)
-> [Int] -> [VersionedTextDocumentIdentifier]
forall a b. (a -> b) -> [a] -> [b]
map (Uri -> TextDocumentVersion -> VersionedTextDocumentIdentifier
VersionedTextDocumentIdentifier Uri
uri (TextDocumentVersion -> VersionedTextDocumentIdentifier)
-> (Int -> TextDocumentVersion)
-> Int
-> VersionedTextDocumentIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TextDocumentVersion
forall a. a -> Maybe a
Just) [Int
curVer Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1..]

        textDocumentEdits :: Uri -> [TextEdit] -> m [TextDocumentEdit]
textDocumentEdits Uri
uri [TextEdit]
edits = do
          [VersionedTextDocumentIdentifier]
vers <- Uri -> m [VersionedTextDocumentIdentifier]
forall (m :: * -> *).
HasState SessionState m =>
Uri -> m [VersionedTextDocumentIdentifier]
textDocumentVersions Uri
uri
          [TextDocumentEdit] -> m [TextDocumentEdit]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TextDocumentEdit] -> m [TextDocumentEdit])
-> [TextDocumentEdit] -> m [TextDocumentEdit]
forall a b. (a -> b) -> a -> b
$ ((VersionedTextDocumentIdentifier, TextEdit) -> TextDocumentEdit)
-> [(VersionedTextDocumentIdentifier, TextEdit)]
-> [TextDocumentEdit]
forall a b. (a -> b) -> [a] -> [b]
map (\(VersionedTextDocumentIdentifier
v, TextEdit
e) -> VersionedTextDocumentIdentifier
-> List TextEdit -> TextDocumentEdit
TextDocumentEdit VersionedTextDocumentIdentifier
v ([TextEdit] -> List TextEdit
forall a. [a] -> List a
List [TextEdit
e])) ([(VersionedTextDocumentIdentifier, TextEdit)]
 -> [TextDocumentEdit])
-> [(VersionedTextDocumentIdentifier, TextEdit)]
-> [TextDocumentEdit]
forall a b. (a -> b) -> a -> b
$ [VersionedTextDocumentIdentifier]
-> [TextEdit] -> [(VersionedTextDocumentIdentifier, TextEdit)]
forall a b. [a] -> [b] -> [(a, b)]
zip [VersionedTextDocumentIdentifier]
vers [TextEdit]
edits

        getChangeParams :: Uri -> List TextEdit -> f [DidChangeTextDocumentParams]
getChangeParams Uri
uri (List [TextEdit]
edits) =
          (TextDocumentEdit -> DidChangeTextDocumentParams)
-> [TextDocumentEdit] -> [DidChangeTextDocumentParams]
forall a b. (a -> b) -> [a] -> [b]
map ((TextDocumentEdit -> DidChangeTextDocumentParams)
 -> [TextDocumentEdit] -> [DidChangeTextDocumentParams])
-> f (TextDocumentEdit -> DidChangeTextDocumentParams)
-> f ([TextDocumentEdit] -> [DidChangeTextDocumentParams])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TextDocumentEdit -> DidChangeTextDocumentParams)
-> f (TextDocumentEdit -> DidChangeTextDocumentParams)
forall (f :: * -> *) a. Applicative f => a -> f a
pure TextDocumentEdit -> DidChangeTextDocumentParams
getParams f ([TextDocumentEdit] -> [DidChangeTextDocumentParams])
-> f [TextDocumentEdit] -> f [DidChangeTextDocumentParams]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Uri -> [TextEdit] -> f [TextDocumentEdit]
forall (m :: * -> *).
HasState SessionState m =>
Uri -> [TextEdit] -> m [TextDocumentEdit]
textDocumentEdits Uri
uri ([TextEdit] -> [TextEdit]
forall a. [a] -> [a]
reverse [TextEdit]
edits)

        mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
        mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
mergeParams [DidChangeTextDocumentParams]
params = let events :: [TextDocumentContentChangeEvent]
events = [[TextDocumentContentChangeEvent]]
-> [TextDocumentContentChangeEvent]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[TextDocumentContentChangeEvent]]
-> [[TextDocumentContentChangeEvent]]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((DidChangeTextDocumentParams -> [TextDocumentContentChangeEvent])
-> [DidChangeTextDocumentParams]
-> [[TextDocumentContentChangeEvent]]
forall a b. (a -> b) -> [a] -> [b]
map (List TextDocumentContentChangeEvent
-> [TextDocumentContentChangeEvent]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (List TextDocumentContentChangeEvent
 -> [TextDocumentContentChangeEvent])
-> (DidChangeTextDocumentParams
    -> List TextDocumentContentChangeEvent)
-> DidChangeTextDocumentParams
-> [TextDocumentContentChangeEvent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DidChangeTextDocumentParams
-> Getting
     (List TextDocumentContentChangeEvent)
     DidChangeTextDocumentParams
     (List TextDocumentContentChangeEvent)
-> List TextDocumentContentChangeEvent
forall s a. s -> Getting a s a -> a
^. Getting
  (List TextDocumentContentChangeEvent)
  DidChangeTextDocumentParams
  (List TextDocumentContentChangeEvent)
forall s a. HasContentChanges s a => Lens' s a
contentChanges)) [DidChangeTextDocumentParams]
params))
                              in VersionedTextDocumentIdentifier
-> List TextDocumentContentChangeEvent
-> DidChangeTextDocumentParams
DidChangeTextDocumentParams ([DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
forall a. [a] -> a
head [DidChangeTextDocumentParams]
params DidChangeTextDocumentParams
-> Getting
     VersionedTextDocumentIdentifier
     DidChangeTextDocumentParams
     VersionedTextDocumentIdentifier
-> VersionedTextDocumentIdentifier
forall s a. s -> Getting a s a -> a
^. Getting
  VersionedTextDocumentIdentifier
  DidChangeTextDocumentParams
  VersionedTextDocumentIdentifier
forall s a. HasTextDocument s a => Lens' s a
textDocument) ([TextDocumentContentChangeEvent]
-> List TextDocumentContentChangeEvent
forall a. [a] -> List a
List [TextDocumentContentChangeEvent]
events)
updateState FromServerMessage
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
sendMessage :: a -> m ()
sendMessage a
msg = do
  Handle
h <- SessionContext -> Handle
serverIn (SessionContext -> Handle) -> m SessionContext -> m Handle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m SessionContext
forall r (m :: * -> *). HasReader r m => m r
ask
  LogMsgType -> a -> m ()
forall a (m :: * -> *).
(ToJSON a, MonadIO m, HasReader SessionContext m) =>
LogMsgType -> a -> m ()
logMsg LogMsgType
LogClient a
msg
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
B.hPut Handle
h (ByteString -> ByteString
addHeader (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
msg)

-- | Execute a block f that will throw a 'Language.Haskell.LSP.Test.Exception.Timeout' exception
-- after duration seconds. This will override the global timeout
-- for waiting for messages to arrive defined in 'SessionConfig'.
withTimeout :: Int -> Session a -> Session a
withTimeout :: Int -> Session a -> Session a
withTimeout Int
duration Session a
f = do
  Chan SessionMessage
chan <- (SessionContext -> Chan SessionMessage)
-> Session (Chan SessionMessage)
forall r (m :: * -> *) b. HasReader r m => (r -> b) -> m b
asks SessionContext -> Chan SessionMessage
messageChan
  Int
timeoutId <- Session Int
forall (m :: * -> *).
(HasReader SessionContext m, MonadIO m) =>
m Int
getCurTimeoutId
  (SessionState -> SessionState) -> Session ()
forall s (m :: * -> *). HasState s m => (s -> s) -> m ()
modify ((SessionState -> SessionState) -> Session ())
-> (SessionState -> SessionState) -> Session ()
forall a b. (a -> b) -> a -> b
$ \SessionState
s -> SessionState
s { overridingTimeout :: Bool
overridingTimeout = Bool
True }
  IO ThreadId -> Session ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> Session ThreadId)
-> IO ThreadId -> Session ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    Int -> IO ()
threadDelay (Int
duration Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000)
    Chan SessionMessage -> SessionMessage -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan SessionMessage
chan (Int -> SessionMessage
TimeoutMessage Int
timeoutId)
  a
res <- Session a
f
  Int -> Session ()
forall (m :: * -> *).
(HasReader SessionContext m, MonadIO m) =>
Int -> m ()
bumpTimeoutId Int
timeoutId
  (SessionState -> SessionState) -> Session ()
forall s (m :: * -> *). HasState s m => (s -> s) -> m ()
modify ((SessionState -> SessionState) -> Session ())
-> (SessionState -> SessionState) -> Session ()
forall a b. (a -> b) -> a -> b
$ \SessionState
s -> SessionState
s { overridingTimeout :: Bool
overridingTimeout = Bool
False }
  a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

data LogMsgType = LogServer | LogClient
  deriving LogMsgType -> LogMsgType -> Bool
(LogMsgType -> LogMsgType -> Bool)
-> (LogMsgType -> LogMsgType -> Bool) -> Eq LogMsgType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogMsgType -> LogMsgType -> Bool
$c/= :: LogMsgType -> LogMsgType -> Bool
== :: LogMsgType -> LogMsgType -> Bool
$c== :: LogMsgType -> LogMsgType -> Bool
Eq

-- | Logs the message if the config specified it
logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m)
       => LogMsgType -> a -> m ()
logMsg :: LogMsgType -> a -> m ()
logMsg LogMsgType
t a
msg = do
  Bool
shouldLog <- (SessionContext -> Bool) -> m Bool
forall r (m :: * -> *) b. HasReader r m => (r -> b) -> m b
asks ((SessionContext -> Bool) -> m Bool)
-> (SessionContext -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ SessionConfig -> Bool
logMessages (SessionConfig -> Bool)
-> (SessionContext -> SessionConfig) -> SessionContext -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionContext -> SessionConfig
config
  Bool
shouldColor <- (SessionContext -> Bool) -> m Bool
forall r (m :: * -> *) b. HasReader r m => (r -> b) -> m b
asks ((SessionContext -> Bool) -> m Bool)
-> (SessionContext -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ SessionConfig -> Bool
logColor (SessionConfig -> Bool)
-> (SessionContext -> SessionConfig) -> SessionContext -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionContext -> SessionConfig
config
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldLog (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldColor (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [SGR] -> IO ()
setSGR [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
color]
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
arrow String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
showPretty a
msg
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldColor (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [SGR] -> IO ()
setSGR [SGR
Reset]

  where arrow :: String
arrow
          | LogMsgType
t LogMsgType -> LogMsgType -> Bool
forall a. Eq a => a -> a -> Bool
== LogMsgType
LogServer  = String
"<-- "
          | Bool
otherwise       = String
"--> "
        color :: Color
color
          | LogMsgType
t LogMsgType -> LogMsgType -> Bool
forall a. Eq a => a -> a -> Bool
== LogMsgType
LogServer  = Color
Magenta
          | Bool
otherwise       = Color
Cyan

        showPretty :: a -> String
showPretty = ByteString -> String
B.unpack (ByteString -> String) -> (a -> ByteString) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty