{- ORMOLU_DISABLE -}

{-# LANGUAGE CPP               #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE TypeInType #-}

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

where

import Control.Applicative
import Control.Concurrent hiding (yield)
import Control.Exception
import Control.Lens hiding (List, Empty)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Catch (MonadThrow)
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, execState)
import qualified Control.Monad.Trans.State as State
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Aeson hiding (Error, Null)
import Data.Aeson.Encode.Pretty
import Data.Aeson.Lens ()
import Data.Conduit as Conduit
import Data.Conduit.Parser as Parser
import Data.Default
import Data.Foldable
import Data.List
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Maybe
import Data.Function
import Language.LSP.Protocol.Types as LSP
import qualified Language.LSP.Protocol.Lens as L
import Language.LSP.Protocol.Message as LSP
import Language.LSP.VFS
import Language.LSP.Test.Compat
import Language.LSP.Test.Decoding
import Language.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 ( timeout )
import Data.IORef
import Colog.Core (LogAction (..), WithSeverity (..), Severity (..))
import Data.Row
import Data.String (fromString)
import Data.Either (partitionEithers)

-- | 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.LSP.Test.message',
-- 'Language.LSP.Test.sendRequest' and
-- 'Language.LSP.Test.sendNotification'.

newtype Session a = Session (ConduitParser FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) a)
  deriving ((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
$cfmap :: forall a b. (a -> b) -> Session a -> Session b
fmap :: forall a b. (a -> b) -> Session a -> Session b
$c<$ :: forall a b. a -> Session b -> Session a
<$ :: forall a b. a -> Session b -> Session a
Functor, Functor Session
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
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
$cpure :: forall a. a -> Session a
pure :: forall a. a -> Session a
$c<*> :: forall a b. Session (a -> b) -> Session a -> Session b
<*> :: forall a b. Session (a -> b) -> Session a -> Session b
$cliftA2 :: forall a b c. (a -> b -> c) -> Session a -> Session b -> Session c
liftA2 :: forall a b c. (a -> b -> c) -> Session a -> Session b -> Session c
$c*> :: forall a b. Session a -> Session b -> Session b
*> :: forall a b. Session a -> Session b -> Session b
$c<* :: forall a b. Session a -> Session b -> Session a
<* :: forall a b. Session a -> Session b -> Session a
Applicative, Applicative Session
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
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
$c>>= :: forall a b. Session a -> (a -> Session b) -> Session b
>>= :: forall a b. Session a -> (a -> Session b) -> Session b
$c>> :: forall a b. Session a -> Session b -> Session b
>> :: forall a b. Session a -> Session b -> Session b
$creturn :: forall a. a -> Session a
return :: forall a. a -> Session a
Monad, Monad Session
Monad Session => (forall a. IO a -> Session a) -> MonadIO Session
forall a. IO a -> Session a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> Session a
liftIO :: forall a. IO a -> Session a
MonadIO, Applicative Session
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
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
$cempty :: forall a. Session a
empty :: forall a. Session a
$c<|> :: forall a. Session a -> Session a -> Session a
<|> :: forall a. Session a -> Session a -> Session a
$csome :: forall a. Session a -> Session [a]
some :: forall a. Session a -> Session [a]
$cmany :: forall a. Session a -> Session [a]
many :: forall a. Session a -> Session [a]
Alternative, Monad Session
Monad Session =>
(forall e a. (HasCallStack, Exception e) => e -> Session a)
-> MonadThrow Session
forall e a. (HasCallStack, Exception e) => e -> Session a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e a. (HasCallStack, Exception e) => e -> Session a
throwM :: forall e a. (HasCallStack, Exception e) => e -> Session a
MonadThrow)

#if __GLASGOW_HASKELL__ >= 806
instance MonadFail Session where
  fail :: forall a. 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 a. 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 -> Object
lspConfig      :: Object
  -- ^ The initial LSP config as JSON object, defaults to the empty object.
  -- This should include the config section for the server if it has one, i.e. if
  -- the server has a 'mylang' config section, then the config should be an object
  -- with a 'mylang' key whose value is the actual config for the server. You
  -- can also include other config sections if your server may request those.
  , SessionConfig -> Bool
ignoreLogNotifications :: Bool
  -- ^ Whether or not to ignore @window/showMessage@ and @window/logMessage@ notifications 
  -- from the server, defaults to True.
  , SessionConfig -> Bool
ignoreConfigurationRequests :: Bool
  -- ^ Whether or not to ignore @workspace/configuration@ requests from the server,
  -- defaults to True.
  , SessionConfig -> Bool
ignoreRegistrationRequests :: Bool
  -- ^ Whether or not to ignore @client/registerCapability@ and @client/unregisterCapability@ 
  -- requests from the server, defaults to True.
  , SessionConfig -> Maybe [WorkspaceFolder]
initialWorkspaceFolders :: Maybe [WorkspaceFolder]
  -- ^ The initial workspace folders to send in the @initialize@ request.
  -- Defaults to Nothing.
  }

-- | The configuration used in 'Language.LSP.Test.runSession'.
defaultConfig :: SessionConfig
defaultConfig :: SessionConfig
defaultConfig = Int
-> Bool
-> Bool
-> Bool
-> Object
-> Bool
-> Bool
-> Bool
-> Maybe [WorkspaceFolder]
-> SessionConfig
SessionConfig Int
60 Bool
False Bool
False Bool
True Object
forall a. Monoid a => a
mempty Bool
True Bool
True Bool
True Maybe [WorkspaceFolder]
forall a. Maybe a
Nothing

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
$cshowsPrec :: Int -> SessionMessage -> ShowS
showsPrec :: Int -> SessionMessage -> ShowS
$cshow :: SessionMessage -> String
show :: SessionMessage -> String
$cshowList :: [SessionMessage] -> ShowS
showList :: [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 -> IORef Int
curTimeoutId :: IORef Int -- ^ The current timeout we are waiting on
  , SessionContext -> MVar RequestMap
requestMap :: MVar RequestMap
  , SessionContext -> MVar (TResponseMessage 'Method_Initialize)
initRsp :: MVar (TResponseMessage Method_Initialize)
  , 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 (m :: * -> *) a.
Monad m =>
m a -> ConduitParser FromServerMessage m a
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 (m :: * -> *) a. Monad m => m a -> StateT SessionState m a
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 (m :: * -> *) a. Monad m => m a -> ConduitT a b m a
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 (m :: * -> *) a. Monad m => m a -> StateT s m a
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 :: forall (m :: * -> *).
(HasReader SessionContext m, MonadIO m) =>
m Int
getCurTimeoutId = (SessionContext -> IORef Int) -> m (IORef Int)
forall b. (SessionContext -> b) -> m b
forall r (m :: * -> *) b. HasReader r m => (r -> b) -> m b
asks SessionContext -> IORef Int
curTimeoutId m (IORef Int) -> (IORef Int -> m Int) -> m Int
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> (IORef Int -> IO Int) -> IORef Int -> m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef

-- Pass this the timeoutid you *were* waiting on
bumpTimeoutId :: (HasReader SessionContext m, MonadIO m) => Int -> m ()
bumpTimeoutId :: forall (m :: * -> *).
(HasReader SessionContext m, MonadIO m) =>
Int -> m ()
bumpTimeoutId Int
prev = do
  IORef Int
v <- (SessionContext -> IORef Int) -> m (IORef Int)
forall b. (SessionContext -> b) -> m b
forall r (m :: * -> *) b. HasReader r m => (r -> b) -> m b
asks SessionContext -> IORef Int
curTimeoutId
  -- when updating the curtimeoutid, account for the fact that something else
  -- might have bumped the timeoutid in the meantime
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
v (\Int
x -> (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 -> Int32
curReqId :: !Int32
  , 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 SomeRegistration
curDynCaps :: !(Map.Map T.Text SomeRegistration)
  -- ^ The capabilities that the server has dynamically registered with us so
  -- far
  , SessionState -> Object
curLspConfig :: Object
  , SessionState -> Set ProgressToken
curProgressSessions :: !(Set.Set ProgressToken)
  , SessionState -> Bool
ignoringLogNotifications :: Bool
  , SessionState -> Bool
ignoringConfigurationRequests :: Bool
  , SessionState -> Bool
ignoringRegistrationRequests :: Bool
  }

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 a b. m a -> (a -> m b) -> m b
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 a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> m s
f m s -> (s -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
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 (m :: * -> *) a.
Monad m =>
m a -> ConduitParser FromServerMessage m a
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 (m :: * -> *) a.
Monad m =>
m a -> ConduitParser FromServerMessage m a
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 (m :: * -> *) a. Monad m => m a -> ConduitT a b m a
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 (m :: * -> *) a. Monad m => m a -> ConduitT a b m a
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 (m :: * -> *) a. Monad m => m a -> ConduitParser a m a
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 (m :: * -> *) a. Monad m => m a -> ConduitParser a m a
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

runSessionMonad :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
runSessionMonad :: forall a.
SessionContext -> SessionState -> Session a -> IO (a, SessionState)
runSessionMonad 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))
  ()
chanSource ConduitT
  ()
  SessionMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
-> ConduitT
     SessionMessage
     Void
     (StateT SessionState (ReaderT SessionContext IO))
     a
-> ConduitT
     () Void (StateT SessionState (ReaderT SessionContext IO)) a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitM
  SessionMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
watchdog ConduitM
  SessionMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
-> ConduitT
     FromServerMessage
     Void
     (StateT SessionState (ReaderT SessionContext IO))
     a
-> ConduitT
     SessionMessage
     Void
     (StateT SessionState (ReaderT SessionContext IO))
     a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitM
  FromServerMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
updateStateC ConduitM
  FromServerMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
-> ConduitT
     FromServerMessage
     Void
     (StateT SessionState (ReaderT SessionContext IO))
     a
-> ConduitT
     FromServerMessage
     Void
     (StateT SessionState (ReaderT SessionContext IO))
     a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitParser
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  a
-> ConduitT
     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 a.
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 a. IO a -> ConduitParser i m a
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
  ()
  SessionMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
chanSource = do
      SessionMessage
msg <- IO SessionMessage
-> ConduitT
     ()
     SessionMessage
     (StateT SessionState (ReaderT SessionContext IO))
     SessionMessage
forall a.
IO a
-> ConduitT
     ()
     SessionMessage
     (StateT SessionState (ReaderT SessionContext IO))
     a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SessionMessage
 -> ConduitT
      ()
      SessionMessage
      (StateT SessionState (ReaderT SessionContext IO))
      SessionMessage)
-> IO SessionMessage
-> ConduitT
     ()
     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)
      SessionMessage
-> ConduitT
     ()
     SessionMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield SessionMessage
msg
      ConduitT
  ()
  SessionMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
chanSource

    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 a b.
ConduitT
  SessionMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  a
-> (a
    -> ConduitT
         SessionMessage
         FromServerMessage
         (StateT SessionState (ReaderT SessionContext IO))
         b)
-> ConduitT
     SessionMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     b
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.
runSession' :: Handle -- ^ Server in
            -> Handle -- ^ Server out
            -> Maybe ProcessHandle -- ^ Server process
            -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
            -> SessionConfig
            -> ClientCapabilities
            -> FilePath -- ^ Root directory
            -> Session () -- ^ To exit the Server properly
            -> Session a
            -> IO a
runSession' :: forall a.
Handle
-> Handle
-> Maybe ProcessHandle
-> (Handle -> SessionContext -> IO ())
-> SessionConfig
-> ClientCapabilities
-> String
-> Session ()
-> Session a
-> IO a
runSession' Handle
serverIn Handle
serverOut Maybe ProcessHandle
mServerProc 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
  IORef Int
timeoutIdVar <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
  MVar (TResponseMessage 'Method_Initialize)
initRsp <- IO (MVar (TResponseMessage 'Method_Initialize))
forall a. IO (MVar a)
newEmptyMVar

  ThreadId
mainThreadId <- IO ThreadId
myThreadId

  let context :: SessionContext
context = Handle
-> String
-> Chan SessionMessage
-> IORef Int
-> MVar RequestMap
-> MVar (TResponseMessage 'Method_Initialize)
-> SessionConfig
-> ClientCapabilities
-> SessionContext
SessionContext
        Handle
serverIn
        String
absRootDir
        Chan SessionMessage
messageChan
        IORef Int
timeoutIdVar
        MVar RequestMap
reqMap
        MVar (TResponseMessage 'Method_Initialize)
initRsp
        SessionConfig
config
        ClientCapabilities
caps
      initState :: SessionState
initState = Int32
-> VFS
-> Map NormalizedUri [Diagnostic]
-> Bool
-> Maybe FromServerMessage
-> Map Text SomeRegistration
-> Object
-> Set ProgressToken
-> Bool
-> Bool
-> Bool
-> SessionState
SessionState
        Int32
0
        VFS
emptyVFS
        Map NormalizedUri [Diagnostic]
forall a. Monoid a => a
mempty
        Bool
False
        Maybe FromServerMessage
forall a. Maybe a
Nothing
        Map Text SomeRegistration
forall a. Monoid a => a
mempty
        (SessionConfig -> Object
lspConfig SessionConfig
config)
        Set ProgressToken
forall a. Monoid a => a
mempty
        (SessionConfig -> Bool
ignoreLogNotifications SessionConfig
config)
        (SessionConfig -> Bool
ignoreConfigurationRequests SessionConfig
config)
        (SessionConfig -> Bool
ignoreRegistrationRequests SessionConfig
config)
      runSession' :: Session () -> IO ((), SessionState)
runSession' = SessionContext
-> SessionState -> Session () -> IO ((), SessionState)
forall a.
SessionContext -> SessionState -> Session a -> IO (a, SessionState)
runSessionMonad SessionContext
context SessionState
initState

      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
      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
        let cleanup :: IO ()
cleanup
              | Just ProcessHandle
sp <- Maybe ProcessHandle
mServerProc = do
                  -- 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
sp)
#endif
                  (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
cleanupProcess (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
serverIn, Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
serverOut, Maybe Handle
forall a. Maybe a
Nothing, ProcessHandle
sp)
              | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        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)
runSession' Session ()
exitServer))
                -- Make sure to kill the listener first, before closing
                -- handles etc via cleanupProcess
                (ThreadId -> IO ()
killThread ThreadId
tid IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
cleanup)

  (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
$ SessionContext -> SessionState -> Session a -> IO (a, SessionState)
forall a.
SessionContext -> SessionState -> Session a -> IO (a, SessionState)
runSessionMonad SessionContext
context SessionState
initState Session a
session)
  a -> IO a
forall a. 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
  SessionState
state <- forall s (m :: * -> *). HasState s m => m s
get @SessionState
  FromServerMessage
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (m :: * -> *).
(MonadIO m, HasReader SessionContext m, HasState SessionState m) =>
FromServerMessage -> m ()
updateState FromServerMessage
msg
  case FromServerMessage
msg of
    FromServerMess SMethod m
SMethod_WindowWorkDoneProgressCreate TMessage m
req ->
      TResponseMessage 'Method_WindowWorkDoneProgressCreate
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage (TResponseMessage 'Method_WindowWorkDoneProgressCreate
 -> ConduitM
      FromServerMessage
      FromServerMessage
      (StateT SessionState (ReaderT SessionContext IO))
      ())
-> TResponseMessage 'Method_WindowWorkDoneProgressCreate
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe (LspId 'Method_WindowWorkDoneProgressCreate)
-> Either
     ResponseError (MessageResult 'Method_WindowWorkDoneProgressCreate)
-> TResponseMessage 'Method_WindowWorkDoneProgressCreate
forall (f :: MessageDirection) (m :: Method f 'Request).
Text
-> Maybe (LspId m)
-> Either ResponseError (MessageResult m)
-> TResponseMessage m
TResponseMessage Text
"2.0" (LspId 'Method_WindowWorkDoneProgressCreate
-> Maybe (LspId 'Method_WindowWorkDoneProgressCreate)
forall a. a -> Maybe a
Just (LspId 'Method_WindowWorkDoneProgressCreate
 -> Maybe (LspId 'Method_WindowWorkDoneProgressCreate))
-> LspId 'Method_WindowWorkDoneProgressCreate
-> Maybe (LspId 'Method_WindowWorkDoneProgressCreate)
forall a b. (a -> b) -> a -> b
$ TMessage m
TRequestMessage 'Method_WindowWorkDoneProgressCreate
req TRequestMessage 'Method_WindowWorkDoneProgressCreate
-> Getting
     (LspId 'Method_WindowWorkDoneProgressCreate)
     (TRequestMessage 'Method_WindowWorkDoneProgressCreate)
     (LspId 'Method_WindowWorkDoneProgressCreate)
-> LspId 'Method_WindowWorkDoneProgressCreate
forall s a. s -> Getting a s a -> a
^. Getting
  (LspId 'Method_WindowWorkDoneProgressCreate)
  (TRequestMessage 'Method_WindowWorkDoneProgressCreate)
  (LspId 'Method_WindowWorkDoneProgressCreate)
forall s a. HasId s a => Lens' s a
Lens'
  (TRequestMessage 'Method_WindowWorkDoneProgressCreate)
  (LspId 'Method_WindowWorkDoneProgressCreate)
L.id) (Null -> Either ResponseError Null
forall a b. b -> Either a b
Right Null
Null)
    FromServerMess SMethod m
SMethod_WorkspaceApplyEdit TMessage m
r -> do
      TResponseMessage 'Method_WorkspaceApplyEdit
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage (TResponseMessage 'Method_WorkspaceApplyEdit
 -> ConduitM
      FromServerMessage
      FromServerMessage
      (StateT SessionState (ReaderT SessionContext IO))
      ())
-> TResponseMessage 'Method_WorkspaceApplyEdit
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe (LspId 'Method_WorkspaceApplyEdit)
-> Either ResponseError (MessageResult 'Method_WorkspaceApplyEdit)
-> TResponseMessage 'Method_WorkspaceApplyEdit
forall (f :: MessageDirection) (m :: Method f 'Request).
Text
-> Maybe (LspId m)
-> Either ResponseError (MessageResult m)
-> TResponseMessage m
TResponseMessage Text
"2.0" (LspId 'Method_WorkspaceApplyEdit
-> Maybe (LspId 'Method_WorkspaceApplyEdit)
forall a. a -> Maybe a
Just (LspId 'Method_WorkspaceApplyEdit
 -> Maybe (LspId 'Method_WorkspaceApplyEdit))
-> LspId 'Method_WorkspaceApplyEdit
-> Maybe (LspId 'Method_WorkspaceApplyEdit)
forall a b. (a -> b) -> a -> b
$ TMessage m
TRequestMessage 'Method_WorkspaceApplyEdit
r TRequestMessage 'Method_WorkspaceApplyEdit
-> Getting
     (LspId 'Method_WorkspaceApplyEdit)
     (TRequestMessage 'Method_WorkspaceApplyEdit)
     (LspId 'Method_WorkspaceApplyEdit)
-> LspId 'Method_WorkspaceApplyEdit
forall s a. s -> Getting a s a -> a
^. Getting
  (LspId 'Method_WorkspaceApplyEdit)
  (TRequestMessage 'Method_WorkspaceApplyEdit)
  (LspId 'Method_WorkspaceApplyEdit)
forall s a. HasId s a => Lens' s a
Lens'
  (TRequestMessage 'Method_WorkspaceApplyEdit)
  (LspId 'Method_WorkspaceApplyEdit)
L.id) (ApplyWorkspaceEditResult
-> Either ResponseError ApplyWorkspaceEditResult
forall a b. b -> Either a b
Right (ApplyWorkspaceEditResult
 -> Either ResponseError ApplyWorkspaceEditResult)
-> ApplyWorkspaceEditResult
-> Either ResponseError ApplyWorkspaceEditResult
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Text -> Maybe UInt -> ApplyWorkspaceEditResult
ApplyWorkspaceEditResult Bool
True Maybe Text
forall a. Maybe a
Nothing Maybe UInt
forall a. Maybe a
Nothing)
    FromServerMess SMethod m
SMethod_WorkspaceConfiguration TMessage m
r -> do
      let requestedSections :: [Text]
requestedSections = (ConfigurationItem -> Maybe Text) -> [ConfigurationItem] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\ConfigurationItem
i -> ConfigurationItem
i ConfigurationItem
-> Getting (First Text) ConfigurationItem Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? (Maybe Text -> Const (First Text) (Maybe Text))
-> ConfigurationItem -> Const (First Text) ConfigurationItem
forall s a. HasSection s a => Lens' s a
Lens' ConfigurationItem (Maybe Text)
L.section ((Maybe Text -> Const (First Text) (Maybe Text))
 -> ConfigurationItem -> Const (First Text) ConfigurationItem)
-> ((Text -> Const (First Text) Text)
    -> Maybe Text -> Const (First Text) (Maybe Text))
-> Getting (First Text) ConfigurationItem Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (First Text) Text)
-> Maybe Text -> Const (First Text) (Maybe Text)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just) ([ConfigurationItem] -> [Text]) -> [ConfigurationItem] -> [Text]
forall a b. (a -> b) -> a -> b
$ TMessage m
TRequestMessage 'Method_WorkspaceConfiguration
r TRequestMessage 'Method_WorkspaceConfiguration
-> Getting
     [ConfigurationItem]
     (TRequestMessage 'Method_WorkspaceConfiguration)
     [ConfigurationItem]
-> [ConfigurationItem]
forall s a. s -> Getting a s a -> a
^. (ConfigurationParams
 -> Const [ConfigurationItem] ConfigurationParams)
-> TRequestMessage 'Method_WorkspaceConfiguration
-> Const
     [ConfigurationItem]
     (TRequestMessage 'Method_WorkspaceConfiguration)
forall s a. HasParams s a => Lens' s a
Lens'
  (TRequestMessage 'Method_WorkspaceConfiguration)
  ConfigurationParams
L.params ((ConfigurationParams
  -> Const [ConfigurationItem] ConfigurationParams)
 -> TRequestMessage 'Method_WorkspaceConfiguration
 -> Const
      [ConfigurationItem]
      (TRequestMessage 'Method_WorkspaceConfiguration))
-> (([ConfigurationItem]
     -> Const [ConfigurationItem] [ConfigurationItem])
    -> ConfigurationParams
    -> Const [ConfigurationItem] ConfigurationParams)
-> Getting
     [ConfigurationItem]
     (TRequestMessage 'Method_WorkspaceConfiguration)
     [ConfigurationItem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ConfigurationItem]
 -> Const [ConfigurationItem] [ConfigurationItem])
-> ConfigurationParams
-> Const [ConfigurationItem] ConfigurationParams
forall s a. HasItems s a => Lens' s a
Lens' ConfigurationParams [ConfigurationItem]
L.items
      let o :: Object
o = SessionState -> Object
curLspConfig SessionState
state
      -- check for each requested section whether we have it
      let configsOrErrs :: [Either Text Value]
configsOrErrs = (((Text -> Either Text Value) -> [Text] -> [Either Text Value])
-> [Text] -> (Text -> Either Text Value) -> [Either Text Value]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Text -> Either Text Value) -> [Text] -> [Either Text Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) [Text]
requestedSections ((Text -> Either Text Value) -> [Either Text Value])
-> (Text -> Either Text Value) -> [Either Text Value]
forall a b. (a -> b) -> a -> b
$ \Text
section ->
            case Object
o Object -> Getting (Maybe Value) Object (Maybe Value) -> Maybe Value
forall s a. s -> Getting a s a -> a
^. Index Object -> Lens' Object (Maybe (IxValue Object))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (String -> Index Object
forall a. IsString a => String -> a
fromString (String -> Index Object) -> String -> Index Object
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
section) of
              Just Value
config -> Value -> Either Text Value
forall a b. b -> Either a b
Right Value
config
              Maybe Value
Nothing -> Text -> Either Text Value
forall a b. a -> Either a b
Left Text
section

      let ([Text]
errs, [Value]
configs) = [Either Text Value] -> ([Text], [Value])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Text Value]
configsOrErrs

      -- we have to return exactly the number of sections requested, so if we can't find all of them then that's an error
      TResponseMessage 'Method_WorkspaceConfiguration
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage (TResponseMessage 'Method_WorkspaceConfiguration
 -> ConduitM
      FromServerMessage
      FromServerMessage
      (StateT SessionState (ReaderT SessionContext IO))
      ())
-> TResponseMessage 'Method_WorkspaceConfiguration
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe (LspId 'Method_WorkspaceConfiguration)
-> Either
     ResponseError (MessageResult 'Method_WorkspaceConfiguration)
-> TResponseMessage 'Method_WorkspaceConfiguration
forall (f :: MessageDirection) (m :: Method f 'Request).
Text
-> Maybe (LspId m)
-> Either ResponseError (MessageResult m)
-> TResponseMessage m
TResponseMessage Text
"2.0" (LspId 'Method_WorkspaceConfiguration
-> Maybe (LspId 'Method_WorkspaceConfiguration)
forall a. a -> Maybe a
Just (LspId 'Method_WorkspaceConfiguration
 -> Maybe (LspId 'Method_WorkspaceConfiguration))
-> LspId 'Method_WorkspaceConfiguration
-> Maybe (LspId 'Method_WorkspaceConfiguration)
forall a b. (a -> b) -> a -> b
$ TMessage m
TRequestMessage 'Method_WorkspaceConfiguration
r TRequestMessage 'Method_WorkspaceConfiguration
-> Getting
     (LspId 'Method_WorkspaceConfiguration)
     (TRequestMessage 'Method_WorkspaceConfiguration)
     (LspId 'Method_WorkspaceConfiguration)
-> LspId 'Method_WorkspaceConfiguration
forall s a. s -> Getting a s a -> a
^. Getting
  (LspId 'Method_WorkspaceConfiguration)
  (TRequestMessage 'Method_WorkspaceConfiguration)
  (LspId 'Method_WorkspaceConfiguration)
forall s a. HasId s a => Lens' s a
Lens'
  (TRequestMessage 'Method_WorkspaceConfiguration)
  (LspId 'Method_WorkspaceConfiguration)
L.id) (Either
   ResponseError (MessageResult 'Method_WorkspaceConfiguration)
 -> TResponseMessage 'Method_WorkspaceConfiguration)
-> Either
     ResponseError (MessageResult 'Method_WorkspaceConfiguration)
-> TResponseMessage 'Method_WorkspaceConfiguration
forall a b. (a -> b) -> a -> b
$
        if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
errs 
        then ([Value] -> Either ResponseError [Value]
forall a b. b -> Either a b
Right [Value]
configs)
        else ResponseError
-> Either
     ResponseError (MessageResult 'Method_WorkspaceConfiguration)
forall a b. a -> Either a b
Left (ResponseError
 -> Either
      ResponseError (MessageResult 'Method_WorkspaceConfiguration))
-> ResponseError
-> Either
     ResponseError (MessageResult 'Method_WorkspaceConfiguration)
forall a b. (a -> b) -> a -> b
$ (LSPErrorCodes |? ErrorCodes)
-> Text -> Maybe Value -> ResponseError
ResponseError (LSPErrorCodes -> LSPErrorCodes |? ErrorCodes
forall a b. a -> a |? b
InL LSPErrorCodes
LSPErrorCodes_RequestFailed) (Text
"No configuration for requested sections: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> String
forall a. Show a => a -> String
show [Text]
errs)) Maybe Value
forall a. Maybe a
Nothing
    FromServerMessage
_ -> ()
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall a.
a
-> ConduitT
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Bool
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (
    (SessionState -> Bool
ignoringLogNotifications SessionState
state Bool -> Bool -> Bool
&& FromServerMessage -> Bool
forall {a :: Method 'ClientToServer 'Request -> *}.
FromServerMessage' a -> Bool
isLogNotification FromServerMessage
msg)
    Bool -> Bool -> Bool
|| (SessionState -> Bool
ignoringConfigurationRequests SessionState
state Bool -> Bool -> Bool
&& FromServerMessage -> Bool
forall {a :: Method 'ClientToServer 'Request -> *}.
FromServerMessage' a -> Bool
isConfigRequest FromServerMessage
msg)
    Bool -> Bool -> Bool
|| (SessionState -> Bool
ignoringRegistrationRequests SessionState
state Bool -> Bool -> Bool
&& FromServerMessage -> Bool
forall {a :: Method 'ClientToServer 'Request -> *}.
FromServerMessage' a -> Bool
isRegistrationRequest FromServerMessage
msg)) (ConduitM
   FromServerMessage
   FromServerMessage
   (StateT SessionState (ReaderT SessionContext IO))
   ()
 -> ConduitM
      FromServerMessage
      FromServerMessage
      (StateT SessionState (ReaderT SessionContext IO))
      ())
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall a b. (a -> b) -> a -> b
$
    FromServerMessage
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield FromServerMessage
msg

  where

    isLogNotification :: FromServerMessage' a -> Bool
isLogNotification (FromServerMess SMethod m
SMethod_WindowShowMessage TMessage m
_) = Bool
True
    isLogNotification (FromServerMess SMethod m
SMethod_WindowLogMessage TMessage m
_) = Bool
True
    isLogNotification (FromServerMess SMethod m
SMethod_WindowShowDocument TMessage m
_) = Bool
True
    isLogNotification FromServerMessage' a
_ = Bool
False

    isConfigRequest :: FromServerMessage' a -> Bool
isConfigRequest (FromServerMess SMethod m
SMethod_WorkspaceConfiguration TMessage m
_) = Bool
True
    isConfigRequest FromServerMessage' a
_ = Bool
False

    isRegistrationRequest :: FromServerMessage' a -> Bool
isRegistrationRequest (FromServerMess SMethod m
SMethod_ClientRegisterCapability TMessage m
_) = Bool
True
    isRegistrationRequest (FromServerMess SMethod m
SMethod_ClientUnregisterCapability TMessage m
_) = Bool
True
    isRegistrationRequest FromServerMessage' a
_ = Bool
False

-- extract Uri out from DocumentChange
-- didn't put this in `lsp-types` because TH was getting in the way
documentChangeUri :: DocumentChange -> Uri
documentChangeUri :: DocumentChange -> Uri
documentChangeUri (InL TextDocumentEdit
x) = TextDocumentEdit
x TextDocumentEdit -> Getting Uri TextDocumentEdit Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (OptionalVersionedTextDocumentIdentifier
 -> Const Uri OptionalVersionedTextDocumentIdentifier)
-> TextDocumentEdit -> Const Uri TextDocumentEdit
forall s a. HasTextDocument s a => Lens' s a
Lens' TextDocumentEdit OptionalVersionedTextDocumentIdentifier
L.textDocument ((OptionalVersionedTextDocumentIdentifier
  -> Const Uri OptionalVersionedTextDocumentIdentifier)
 -> TextDocumentEdit -> Const Uri TextDocumentEdit)
-> ((Uri -> Const Uri Uri)
    -> OptionalVersionedTextDocumentIdentifier
    -> Const Uri OptionalVersionedTextDocumentIdentifier)
-> Getting Uri TextDocumentEdit Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> OptionalVersionedTextDocumentIdentifier
-> Const Uri OptionalVersionedTextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
Lens' OptionalVersionedTextDocumentIdentifier Uri
L.uri
documentChangeUri (InR (InL CreateFile
x)) = CreateFile
x CreateFile -> Getting Uri CreateFile Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri CreateFile Uri
forall s a. HasUri s a => Lens' s a
Lens' CreateFile Uri
L.uri
documentChangeUri (InR (InR (InL RenameFile
x))) = RenameFile
x RenameFile -> Getting Uri RenameFile Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri RenameFile Uri
forall s a. HasOldUri s a => Lens' s a
Lens' RenameFile Uri
L.oldUri
documentChangeUri (InR (InR (InR DeleteFile
x))) = DeleteFile
x DeleteFile -> Getting Uri DeleteFile Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri DeleteFile Uri
forall s a. HasUri s a => Lens' s a
Lens' DeleteFile Uri
L.uri

updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
            => FromServerMessage -> m ()
updateState :: forall (m :: * -> *).
(MonadIO m, HasReader SessionContext m, HasState SessionState m) =>
FromServerMessage -> m ()
updateState (FromServerMess SMethod m
SMethod_Progress TMessage m
req) = case TMessage m
TNotificationMessage 'Method_Progress
req TNotificationMessage 'Method_Progress
-> Getting Value (TNotificationMessage 'Method_Progress) Value
-> Value
forall s a. s -> Getting a s a -> a
^. (ProgressParams -> Const Value ProgressParams)
-> TNotificationMessage 'Method_Progress
-> Const Value (TNotificationMessage 'Method_Progress)
forall s a. HasParams s a => Lens' s a
Lens' (TNotificationMessage 'Method_Progress) ProgressParams
L.params ((ProgressParams -> Const Value ProgressParams)
 -> TNotificationMessage 'Method_Progress
 -> Const Value (TNotificationMessage 'Method_Progress))
-> ((Value -> Const Value Value)
    -> ProgressParams -> Const Value ProgressParams)
-> Getting Value (TNotificationMessage 'Method_Progress) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const Value Value)
-> ProgressParams -> Const Value ProgressParams
forall s a. HasValue s a => Lens' s a
Lens' ProgressParams Value
L.value of
  Value
v | Just WorkDoneProgressBegin
_ <- Value
v Value
-> Getting
     (First WorkDoneProgressBegin) Value WorkDoneProgressBegin
-> Maybe WorkDoneProgressBegin
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First WorkDoneProgressBegin) Value WorkDoneProgressBegin
Prism' Value WorkDoneProgressBegin
_workDoneProgressBegin ->
    (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.insert (req ^. L.params . L.token) $ curProgressSessions s }
  Value
v | Just WorkDoneProgressEnd
_ <- Value
v Value
-> Getting (First WorkDoneProgressEnd) Value WorkDoneProgressEnd
-> Maybe WorkDoneProgressEnd
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First WorkDoneProgressEnd) Value WorkDoneProgressEnd
Prism' Value WorkDoneProgressEnd
_workDoneProgressEnd ->
    (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.delete (req ^. L.params . L.token) $ curProgressSessions s }
  Value
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- Keep track of dynamic capability registration
updateState (FromServerMess SMethod m
SMethod_ClientRegisterCapability TMessage m
req) = do
  let
    regs :: [SomeRegistration]
    regs :: [SomeRegistration]
regs = TMessage m
TRequestMessage 'Method_ClientRegisterCapability
req TRequestMessage 'Method_ClientRegisterCapability
-> Getting
     (Endo [SomeRegistration])
     (TRequestMessage 'Method_ClientRegisterCapability)
     SomeRegistration
-> [SomeRegistration]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (RegistrationParams
 -> Const (Endo [SomeRegistration]) RegistrationParams)
-> TRequestMessage 'Method_ClientRegisterCapability
-> Const
     (Endo [SomeRegistration])
     (TRequestMessage 'Method_ClientRegisterCapability)
forall s a. HasParams s a => Lens' s a
Lens'
  (TRequestMessage 'Method_ClientRegisterCapability)
  RegistrationParams
L.params ((RegistrationParams
  -> Const (Endo [SomeRegistration]) RegistrationParams)
 -> TRequestMessage 'Method_ClientRegisterCapability
 -> Const
      (Endo [SomeRegistration])
      (TRequestMessage 'Method_ClientRegisterCapability))
-> ((SomeRegistration
     -> Const (Endo [SomeRegistration]) SomeRegistration)
    -> RegistrationParams
    -> Const (Endo [SomeRegistration]) RegistrationParams)
-> Getting
     (Endo [SomeRegistration])
     (TRequestMessage 'Method_ClientRegisterCapability)
     SomeRegistration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Registration] -> Const (Endo [SomeRegistration]) [Registration])
-> RegistrationParams
-> Const (Endo [SomeRegistration]) RegistrationParams
forall s a. HasRegistrations s a => Lens' s a
Lens' RegistrationParams [Registration]
L.registrations (([Registration] -> Const (Endo [SomeRegistration]) [Registration])
 -> RegistrationParams
 -> Const (Endo [SomeRegistration]) RegistrationParams)
-> ((SomeRegistration
     -> Const (Endo [SomeRegistration]) SomeRegistration)
    -> [Registration]
    -> Const (Endo [SomeRegistration]) [Registration])
-> (SomeRegistration
    -> Const (Endo [SomeRegistration]) SomeRegistration)
-> RegistrationParams
-> Const (Endo [SomeRegistration]) RegistrationParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Registration -> Const (Endo [SomeRegistration]) Registration)
-> [Registration] -> Const (Endo [SomeRegistration]) [Registration]
forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
IndexedTraversal
  Int [Registration] [Registration] Registration Registration
traversed ((Registration -> Const (Endo [SomeRegistration]) Registration)
 -> [Registration]
 -> Const (Endo [SomeRegistration]) [Registration])
-> ((SomeRegistration
     -> Const (Endo [SomeRegistration]) SomeRegistration)
    -> Registration -> Const (Endo [SomeRegistration]) Registration)
-> (SomeRegistration
    -> Const (Endo [SomeRegistration]) SomeRegistration)
-> [Registration]
-> Const (Endo [SomeRegistration]) [Registration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Registration -> Maybe SomeRegistration)
-> Optic'
     (->)
     (Const (Endo [SomeRegistration]))
     Registration
     (Maybe SomeRegistration)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Registration -> Maybe SomeRegistration
toSomeRegistration Optic'
  (->)
  (Const (Endo [SomeRegistration]))
  Registration
  (Maybe SomeRegistration)
-> ((SomeRegistration
     -> Const (Endo [SomeRegistration]) SomeRegistration)
    -> Maybe SomeRegistration
    -> Const (Endo [SomeRegistration]) (Maybe SomeRegistration))
-> (SomeRegistration
    -> Const (Endo [SomeRegistration]) SomeRegistration)
-> Registration
-> Const (Endo [SomeRegistration]) Registration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomeRegistration
 -> Const (Endo [SomeRegistration]) SomeRegistration)
-> Maybe SomeRegistration
-> Const (Endo [SomeRegistration]) (Maybe SomeRegistration)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just
  let newRegs :: [(Text, SomeRegistration)]
newRegs = (\sr :: SomeRegistration
sr@(SomeRegistration TRegistration m
r) -> (TRegistration m
r TRegistration m -> Getting Text (TRegistration m) Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text (TRegistration m) Text
forall s a. HasId s a => Lens' s a
Lens' (TRegistration m) Text
L.id, SomeRegistration
sr)) (SomeRegistration -> (Text, SomeRegistration))
-> [SomeRegistration] -> [(Text, SomeRegistration)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SomeRegistration]
regs
  (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.union (Map.fromList newRegs) (curDynCaps s) }

updateState (FromServerMess SMethod m
SMethod_ClientUnregisterCapability TMessage m
req) = do
  let unRegs :: [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
Lens' Unregistration Text
L.id) (Unregistration -> Text) -> [Unregistration] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMessage m
TRequestMessage 'Method_ClientUnregisterCapability
req TRequestMessage 'Method_ClientUnregisterCapability
-> Getting
     [Unregistration]
     (TRequestMessage 'Method_ClientUnregisterCapability)
     [Unregistration]
-> [Unregistration]
forall s a. s -> Getting a s a -> a
^. (UnregistrationParams
 -> Const [Unregistration] UnregistrationParams)
-> TRequestMessage 'Method_ClientUnregisterCapability
-> Const
     [Unregistration]
     (TRequestMessage 'Method_ClientUnregisterCapability)
forall s a. HasParams s a => Lens' s a
Lens'
  (TRequestMessage 'Method_ClientUnregisterCapability)
  UnregistrationParams
L.params ((UnregistrationParams
  -> Const [Unregistration] UnregistrationParams)
 -> TRequestMessage 'Method_ClientUnregisterCapability
 -> Const
      [Unregistration]
      (TRequestMessage 'Method_ClientUnregisterCapability))
-> (([Unregistration] -> Const [Unregistration] [Unregistration])
    -> UnregistrationParams
    -> Const [Unregistration] UnregistrationParams)
-> Getting
     [Unregistration]
     (TRequestMessage 'Method_ClientUnregisterCapability)
     [Unregistration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Unregistration] -> Const [Unregistration] [Unregistration])
-> UnregistrationParams
-> Const [Unregistration] UnregistrationParams
forall s a. HasUnregisterations s a => Lens' s a
Lens' UnregistrationParams [Unregistration]
L.unregisterations
  (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 SomeRegistration
newCurDynCaps = (Text -> Map Text SomeRegistration -> Map Text SomeRegistration)
-> Map Text SomeRegistration -> [Text] -> Map Text SomeRegistration
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' Text -> Map Text SomeRegistration -> Map Text SomeRegistration
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (SessionState -> Map Text SomeRegistration
curDynCaps SessionState
s) [Text]
unRegs
    in SessionState
s { curDynCaps = newCurDynCaps }

updateState (FromServerMess SMethod m
SMethod_TextDocumentPublishDiagnostics TMessage m
n) = do
  let diags :: [Diagnostic]
diags = TMessage m
TNotificationMessage 'Method_TextDocumentPublishDiagnostics
n TNotificationMessage 'Method_TextDocumentPublishDiagnostics
-> Getting
     [Diagnostic]
     (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
     [Diagnostic]
-> [Diagnostic]
forall s a. s -> Getting a s a -> a
^. (PublishDiagnosticsParams
 -> Const [Diagnostic] PublishDiagnosticsParams)
-> TNotificationMessage 'Method_TextDocumentPublishDiagnostics
-> Const
     [Diagnostic]
     (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
forall s a. HasParams s a => Lens' s a
Lens'
  (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
  PublishDiagnosticsParams
L.params ((PublishDiagnosticsParams
  -> Const [Diagnostic] PublishDiagnosticsParams)
 -> TNotificationMessage 'Method_TextDocumentPublishDiagnostics
 -> Const
      [Diagnostic]
      (TNotificationMessage 'Method_TextDocumentPublishDiagnostics))
-> (([Diagnostic] -> Const [Diagnostic] [Diagnostic])
    -> PublishDiagnosticsParams
    -> Const [Diagnostic] PublishDiagnosticsParams)
-> Getting
     [Diagnostic]
     (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
     [Diagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Diagnostic] -> Const [Diagnostic] [Diagnostic])
-> PublishDiagnosticsParams
-> Const [Diagnostic] PublishDiagnosticsParams
forall s a. HasDiagnostics s a => Lens' s a
Lens' PublishDiagnosticsParams [Diagnostic]
L.diagnostics
      doc :: Uri
doc = TMessage m
TNotificationMessage 'Method_TextDocumentPublishDiagnostics
n TNotificationMessage 'Method_TextDocumentPublishDiagnostics
-> Getting
     Uri
     (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
     Uri
-> Uri
forall s a. s -> Getting a s a -> a
^. (PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
-> TNotificationMessage 'Method_TextDocumentPublishDiagnostics
-> Const
     Uri (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
forall s a. HasParams s a => Lens' s a
Lens'
  (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
  PublishDiagnosticsParams
L.params ((PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
 -> TNotificationMessage 'Method_TextDocumentPublishDiagnostics
 -> Const
      Uri (TNotificationMessage 'Method_TextDocumentPublishDiagnostics))
-> ((Uri -> Const Uri Uri)
    -> PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
-> Getting
     Uri
     (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
     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
Lens' PublishDiagnosticsParams Uri
L.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 = newDiags }

updateState (FromServerMess SMethod m
SMethod_WorkspaceApplyEdit TMessage m
r) = do

  -- First, prefer the versioned documentChanges field
  [DidChangeTextDocumentParams]
allChangeParams <- case TMessage m
TRequestMessage 'Method_WorkspaceApplyEdit
r TRequestMessage 'Method_WorkspaceApplyEdit
-> Getting
     (Maybe [DocumentChange])
     (TRequestMessage 'Method_WorkspaceApplyEdit)
     (Maybe [DocumentChange])
-> Maybe [DocumentChange]
forall s a. s -> Getting a s a -> a
^. (ApplyWorkspaceEditParams
 -> Const (Maybe [DocumentChange]) ApplyWorkspaceEditParams)
-> TRequestMessage 'Method_WorkspaceApplyEdit
-> Const
     (Maybe [DocumentChange])
     (TRequestMessage 'Method_WorkspaceApplyEdit)
forall s a. HasParams s a => Lens' s a
Lens'
  (TRequestMessage 'Method_WorkspaceApplyEdit)
  ApplyWorkspaceEditParams
L.params ((ApplyWorkspaceEditParams
  -> Const (Maybe [DocumentChange]) ApplyWorkspaceEditParams)
 -> TRequestMessage 'Method_WorkspaceApplyEdit
 -> Const
      (Maybe [DocumentChange])
      (TRequestMessage 'Method_WorkspaceApplyEdit))
-> ((Maybe [DocumentChange]
     -> Const (Maybe [DocumentChange]) (Maybe [DocumentChange]))
    -> ApplyWorkspaceEditParams
    -> Const (Maybe [DocumentChange]) ApplyWorkspaceEditParams)
-> Getting
     (Maybe [DocumentChange])
     (TRequestMessage 'Method_WorkspaceApplyEdit)
     (Maybe [DocumentChange])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WorkspaceEdit -> Const (Maybe [DocumentChange]) WorkspaceEdit)
-> ApplyWorkspaceEditParams
-> Const (Maybe [DocumentChange]) ApplyWorkspaceEditParams
forall s a. HasEdit s a => Lens' s a
Lens' ApplyWorkspaceEditParams WorkspaceEdit
L.edit ((WorkspaceEdit -> Const (Maybe [DocumentChange]) WorkspaceEdit)
 -> ApplyWorkspaceEditParams
 -> Const (Maybe [DocumentChange]) ApplyWorkspaceEditParams)
-> ((Maybe [DocumentChange]
     -> Const (Maybe [DocumentChange]) (Maybe [DocumentChange]))
    -> WorkspaceEdit -> Const (Maybe [DocumentChange]) WorkspaceEdit)
-> (Maybe [DocumentChange]
    -> Const (Maybe [DocumentChange]) (Maybe [DocumentChange]))
-> ApplyWorkspaceEditParams
-> Const (Maybe [DocumentChange]) ApplyWorkspaceEditParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe [DocumentChange]
 -> Const (Maybe [DocumentChange]) (Maybe [DocumentChange]))
-> WorkspaceEdit -> Const (Maybe [DocumentChange]) WorkspaceEdit
forall s a. HasDocumentChanges s a => Lens' s a
Lens' WorkspaceEdit (Maybe [DocumentChange])
L.documentChanges of
    Just ([DocumentChange]
cs) -> do
      (DocumentChange -> m ()) -> [DocumentChange] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Uri -> m ()
checkIfNeedsOpened (Uri -> m ()) -> (DocumentChange -> Uri) -> DocumentChange -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocumentChange -> Uri
documentChangeUri) [DocumentChange]
cs
      -- replace the user provided version numbers with the VFS ones + 1
      -- (technically we should check that the user versions match the VFS ones)
      [DocumentChange]
cs' <- LensLike
  m
  [DocumentChange]
  [DocumentChange]
  VersionedTextDocumentIdentifier
  VersionedTextDocumentIdentifier
-> LensLike
     m
     [DocumentChange]
     [DocumentChange]
     VersionedTextDocumentIdentifier
     VersionedTextDocumentIdentifier
forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
traverseOf ((DocumentChange -> m DocumentChange)
-> [DocumentChange] -> m [DocumentChange]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((DocumentChange -> m DocumentChange)
 -> [DocumentChange] -> m [DocumentChange])
-> ((VersionedTextDocumentIdentifier
     -> m VersionedTextDocumentIdentifier)
    -> DocumentChange -> m DocumentChange)
-> LensLike
     m
     [DocumentChange]
     [DocumentChange]
     VersionedTextDocumentIdentifier
     VersionedTextDocumentIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentEdit -> m TextDocumentEdit)
-> DocumentChange -> m DocumentChange
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f a) -> p (a |? b) (f (a |? b))
_L ((TextDocumentEdit -> m TextDocumentEdit)
 -> DocumentChange -> m DocumentChange)
-> ((VersionedTextDocumentIdentifier
     -> m VersionedTextDocumentIdentifier)
    -> TextDocumentEdit -> m TextDocumentEdit)
-> (VersionedTextDocumentIdentifier
    -> m VersionedTextDocumentIdentifier)
-> DocumentChange
-> m DocumentChange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OptionalVersionedTextDocumentIdentifier
 -> m OptionalVersionedTextDocumentIdentifier)
-> TextDocumentEdit -> m TextDocumentEdit
forall s a. HasTextDocument s a => Lens' s a
Lens' TextDocumentEdit OptionalVersionedTextDocumentIdentifier
L.textDocument ((OptionalVersionedTextDocumentIdentifier
  -> m OptionalVersionedTextDocumentIdentifier)
 -> TextDocumentEdit -> m TextDocumentEdit)
-> ((VersionedTextDocumentIdentifier
     -> m VersionedTextDocumentIdentifier)
    -> OptionalVersionedTextDocumentIdentifier
    -> m OptionalVersionedTextDocumentIdentifier)
-> (VersionedTextDocumentIdentifier
    -> m VersionedTextDocumentIdentifier)
-> TextDocumentEdit
-> m TextDocumentEdit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VersionedTextDocumentIdentifier
 -> m VersionedTextDocumentIdentifier)
-> OptionalVersionedTextDocumentIdentifier
-> m OptionalVersionedTextDocumentIdentifier
Prism'
  OptionalVersionedTextDocumentIdentifier
  VersionedTextDocumentIdentifier
_versionedTextDocumentIdentifier) VersionedTextDocumentIdentifier
-> m VersionedTextDocumentIdentifier
forall {f :: * -> *}.
HasState SessionState f =>
VersionedTextDocumentIdentifier
-> f VersionedTextDocumentIdentifier
bumpNewestVersion [DocumentChange]
cs
      [DidChangeTextDocumentParams] -> m [DidChangeTextDocumentParams]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DidChangeTextDocumentParams] -> m [DidChangeTextDocumentParams])
-> [DidChangeTextDocumentParams] -> m [DidChangeTextDocumentParams]
forall a b. (a -> b) -> a -> b
$ (DocumentChange -> Maybe DidChangeTextDocumentParams)
-> [DocumentChange] -> [DidChangeTextDocumentParams]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DocumentChange -> Maybe DidChangeTextDocumentParams
getParamsFromDocumentChange [DocumentChange]
cs'
    -- Then fall back to the changes field
    Maybe [DocumentChange]
Nothing -> case TMessage m
TRequestMessage 'Method_WorkspaceApplyEdit
r TRequestMessage 'Method_WorkspaceApplyEdit
-> Getting
     (Maybe (Map Uri [TextEdit]))
     (TRequestMessage 'Method_WorkspaceApplyEdit)
     (Maybe (Map Uri [TextEdit]))
-> Maybe (Map Uri [TextEdit])
forall s a. s -> Getting a s a -> a
^. (ApplyWorkspaceEditParams
 -> Const (Maybe (Map Uri [TextEdit])) ApplyWorkspaceEditParams)
-> TRequestMessage 'Method_WorkspaceApplyEdit
-> Const
     (Maybe (Map Uri [TextEdit]))
     (TRequestMessage 'Method_WorkspaceApplyEdit)
forall s a. HasParams s a => Lens' s a
Lens'
  (TRequestMessage 'Method_WorkspaceApplyEdit)
  ApplyWorkspaceEditParams
L.params ((ApplyWorkspaceEditParams
  -> Const (Maybe (Map Uri [TextEdit])) ApplyWorkspaceEditParams)
 -> TRequestMessage 'Method_WorkspaceApplyEdit
 -> Const
      (Maybe (Map Uri [TextEdit]))
      (TRequestMessage 'Method_WorkspaceApplyEdit))
-> ((Maybe (Map Uri [TextEdit])
     -> Const (Maybe (Map Uri [TextEdit])) (Maybe (Map Uri [TextEdit])))
    -> ApplyWorkspaceEditParams
    -> Const (Maybe (Map Uri [TextEdit])) ApplyWorkspaceEditParams)
-> Getting
     (Maybe (Map Uri [TextEdit]))
     (TRequestMessage 'Method_WorkspaceApplyEdit)
     (Maybe (Map Uri [TextEdit]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WorkspaceEdit -> Const (Maybe (Map Uri [TextEdit])) WorkspaceEdit)
-> ApplyWorkspaceEditParams
-> Const (Maybe (Map Uri [TextEdit])) ApplyWorkspaceEditParams
forall s a. HasEdit s a => Lens' s a
Lens' ApplyWorkspaceEditParams WorkspaceEdit
L.edit ((WorkspaceEdit
  -> Const (Maybe (Map Uri [TextEdit])) WorkspaceEdit)
 -> ApplyWorkspaceEditParams
 -> Const (Maybe (Map Uri [TextEdit])) ApplyWorkspaceEditParams)
-> ((Maybe (Map Uri [TextEdit])
     -> Const (Maybe (Map Uri [TextEdit])) (Maybe (Map Uri [TextEdit])))
    -> WorkspaceEdit
    -> Const (Maybe (Map Uri [TextEdit])) WorkspaceEdit)
-> (Maybe (Map Uri [TextEdit])
    -> Const (Maybe (Map Uri [TextEdit])) (Maybe (Map Uri [TextEdit])))
-> ApplyWorkspaceEditParams
-> Const (Maybe (Map Uri [TextEdit])) ApplyWorkspaceEditParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Map Uri [TextEdit])
 -> Const (Maybe (Map Uri [TextEdit])) (Maybe (Map Uri [TextEdit])))
-> WorkspaceEdit
-> Const (Maybe (Map Uri [TextEdit])) WorkspaceEdit
forall s a. HasChanges s a => Lens' s a
Lens' WorkspaceEdit (Maybe (Map Uri [TextEdit]))
L.changes of
      Just Map Uri [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 ()
checkIfNeedsOpened (Map Uri [TextEdit] -> [Uri]
forall k a. Map k a -> [k]
Map.keys Map Uri [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, [TextEdit]) -> m [DidChangeTextDocumentParams])
-> [(Uri, [TextEdit])] -> m [[DidChangeTextDocumentParams]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Uri -> [TextEdit] -> m [DidChangeTextDocumentParams])
-> (Uri, [TextEdit]) -> m [DidChangeTextDocumentParams]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Uri -> [TextEdit] -> m [DidChangeTextDocumentParams]
forall {m :: * -> *}.
HasState SessionState m =>
Uri -> [TextEdit] -> m [DidChangeTextDocumentParams]
getChangeParams) (Map Uri [TextEdit] -> [(Uri, [TextEdit])]
forall k a. Map k a -> [(k, a)]
Map.toList Map Uri [TextEdit]
cs)
      Maybe (Map Uri [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
    let newVFS :: VFS
newVFS = (State VFS () -> VFS -> VFS) -> VFS -> State VFS () -> VFS
forall a b c. (a -> b -> c) -> b -> a -> c
flip State VFS () -> VFS -> VFS
forall s a. State s a -> s -> s
execState (SessionState -> VFS
vfs SessionState
s) (State VFS () -> VFS) -> State VFS () -> VFS
forall a b. (a -> b) -> a -> b
$ LogAction (StateT VFS Identity) (WithSeverity VfsLog)
-> TMessage 'Method_WorkspaceApplyEdit -> State VFS ()
forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> TMessage 'Method_WorkspaceApplyEdit -> m ()
changeFromServerVFS LogAction (StateT VFS Identity) (WithSeverity VfsLog)
logger TMessage m
TMessage 'Method_WorkspaceApplyEdit
r
    SessionState -> m SessionState
forall a. a -> m a
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 = 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
Lens' DidChangeTextDocumentParams VersionedTextDocumentIdentifier
L.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
Lens' DidChangeTextDocumentParams VersionedTextDocumentIdentifier
L.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 (TNotificationMessage 'Method_TextDocumentDidChange -> m ()
forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage (TNotificationMessage 'Method_TextDocumentDidChange -> m ())
-> (DidChangeTextDocumentParams
    -> TNotificationMessage 'Method_TextDocumentDidChange)
-> DidChangeTextDocumentParams
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> SMethod 'Method_TextDocumentDidChange
-> MessageParams 'Method_TextDocumentDidChange
-> TNotificationMessage 'Method_TextDocumentDidChange
forall (f :: MessageDirection) (m :: Method f 'Notification).
Text -> SMethod m -> MessageParams m -> TNotificationMessage m
TNotificationMessage Text
"2.0" SMethod 'Method_TextDocumentDidChange
SMethod_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 (Int32 -> Int32 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int32 -> Int32 -> Ordering)
-> (DidChangeTextDocumentParams -> Int32)
-> DidChangeTextDocumentParams
-> DidChangeTextDocumentParams
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (DidChangeTextDocumentParams
-> Getting Int32 DidChangeTextDocumentParams Int32 -> Int32
forall s a. s -> Getting a s a -> a
^. (VersionedTextDocumentIdentifier
 -> Const Int32 VersionedTextDocumentIdentifier)
-> DidChangeTextDocumentParams
-> Const Int32 DidChangeTextDocumentParams
forall s a. HasTextDocument s a => Lens' s a
Lens' DidChangeTextDocumentParams VersionedTextDocumentIdentifier
L.textDocument ((VersionedTextDocumentIdentifier
  -> Const Int32 VersionedTextDocumentIdentifier)
 -> DidChangeTextDocumentParams
 -> Const Int32 DidChangeTextDocumentParams)
-> ((Int32 -> Const Int32 Int32)
    -> VersionedTextDocumentIdentifier
    -> Const Int32 VersionedTextDocumentIdentifier)
-> Getting Int32 DidChangeTextDocumentParams Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int32 -> Const Int32 Int32)
-> VersionedTextDocumentIdentifier
-> Const Int32 VersionedTextDocumentIdentifier
forall s a. HasVersion s a => Lens' s a
Lens' VersionedTextDocumentIdentifier Int32
L.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
Lens' DidChangeTextDocumentParams VersionedTextDocumentIdentifier
L.textDocument) (DidChangeTextDocumentParams -> VersionedTextDocumentIdentifier)
-> ([DidChangeTextDocumentParams] -> DidChangeTextDocumentParams)
-> [DidChangeTextDocumentParams]
-> VersionedTextDocumentIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
forall a. HasCallStack => [a] -> a
last) [[DidChangeTextDocumentParams]]
sortedVersions

  [VersionedTextDocumentIdentifier]
-> (VersionedTextDocumentIdentifier -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [VersionedTextDocumentIdentifier]
latestVersions ((VersionedTextDocumentIdentifier -> m ()) -> m ())
-> (VersionedTextDocumentIdentifier -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(VersionedTextDocumentIdentifier Uri
uri Int32
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 Int32
_ Int
file_ver Rope
t) = Int32 -> Int -> Rope -> VirtualFile
VirtualFile Int32
v (Int
file_ver Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Rope
t
          newVFS :: VFS
newVFS = VFS
oldVFS VFS -> (VFS -> VFS) -> VFS
forall a b. a -> (a -> b) -> b
& (Map NormalizedUri VirtualFile
 -> Identity (Map NormalizedUri VirtualFile))
-> VFS -> Identity VFS
forall s a. HasVfsMap s a => Lens' s a
Lens' VFS (Map NormalizedUri VirtualFile)
vfsMap ((Map NormalizedUri VirtualFile
  -> Identity (Map NormalizedUri VirtualFile))
 -> VFS -> Identity VFS)
-> ((VirtualFile -> Identity VirtualFile)
    -> Map NormalizedUri VirtualFile
    -> Identity (Map NormalizedUri VirtualFile))
-> (VirtualFile -> Identity VirtualFile)
-> VFS
-> Identity VFS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map NormalizedUri VirtualFile)
-> Traversal'
     (Map NormalizedUri VirtualFile)
     (IxValue (Map NormalizedUri VirtualFile))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (Uri -> NormalizedUri
toNormalizedUri Uri
uri) ((VirtualFile -> Identity VirtualFile) -> VFS -> Identity VFS)
-> (VirtualFile -> VirtualFile) -> VFS -> VFS
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ VirtualFile -> VirtualFile
update
      in SessionState
s { vfs = newVFS }

  where
        logger :: LogAction (StateT VFS Identity) (WithSeverity VfsLog)
logger = (WithSeverity VfsLog -> State VFS ())
-> LogAction (StateT VFS Identity) (WithSeverity VfsLog)
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction ((WithSeverity VfsLog -> State VFS ())
 -> LogAction (StateT VFS Identity) (WithSeverity VfsLog))
-> (WithSeverity VfsLog -> State VFS ())
-> LogAction (StateT VFS Identity) (WithSeverity VfsLog)
forall a b. (a -> b) -> a -> b
$ \(WithSeverity VfsLog
msg Severity
sev) -> case Severity
sev of { Severity
Error -> String -> State VFS ()
forall a. HasCallStack => String -> a
error (String -> State VFS ()) -> String -> State VFS ()
forall a b. (a -> b) -> a -> b
$ VfsLog -> String
forall a. Show a => a -> String
show VfsLog
msg; Severity
_ -> () -> State VFS ()
forall a. a -> StateT VFS Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () }
        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

          -- if its not open, open it
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Getting Any VFS (IxValue (Map NormalizedUri VirtualFile))
-> VFS -> Bool
forall s a. Getting Any s a -> s -> Bool
has ((Map NormalizedUri VirtualFile
 -> Const Any (Map NormalizedUri VirtualFile))
-> VFS -> Const Any VFS
forall s a. HasVfsMap s a => Lens' s a
Lens' VFS (Map NormalizedUri VirtualFile)
vfsMap ((Map NormalizedUri VirtualFile
  -> Const Any (Map NormalizedUri VirtualFile))
 -> VFS -> Const Any VFS)
-> ((IxValue (Map NormalizedUri VirtualFile)
     -> Const Any (IxValue (Map NormalizedUri VirtualFile)))
    -> Map NormalizedUri VirtualFile
    -> Const Any (Map NormalizedUri VirtualFile))
-> Getting Any VFS (IxValue (Map NormalizedUri VirtualFile))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map NormalizedUri VirtualFile)
-> Traversal'
     (Map NormalizedUri VirtualFile)
     (IxValue (Map NormalizedUri VirtualFile))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (Uri -> NormalizedUri
toNormalizedUri Uri
uri)) 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 a. IO a -> m a
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 -> Int32 -> Text -> TextDocumentItem
TextDocumentItem (String -> Uri
filePathToUri String
fp) Text
"" Int32
0 Text
contents
                msg :: TNotificationMessage 'Method_TextDocumentDidOpen
msg = Text
-> SMethod 'Method_TextDocumentDidOpen
-> MessageParams 'Method_TextDocumentDidOpen
-> TNotificationMessage 'Method_TextDocumentDidOpen
forall (f :: MessageDirection) (m :: Method f 'Notification).
Text -> SMethod m -> MessageParams m -> TNotificationMessage m
TNotificationMessage Text
"2.0" SMethod 'Method_TextDocumentDidOpen
SMethod_TextDocumentDidOpen (TextDocumentItem -> DidOpenTextDocumentParams
DidOpenTextDocumentParams TextDocumentItem
item)
            TNotificationMessage 'Method_TextDocumentDidOpen -> m ()
forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage TNotificationMessage 'Method_TextDocumentDidOpen
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 newVFS :: VFS
newVFS = (State VFS () -> VFS -> VFS) -> VFS -> State VFS () -> VFS
forall a b c. (a -> b -> c) -> b -> a -> c
flip State VFS () -> VFS -> VFS
forall s a. State s a -> s -> s
execState (SessionState -> VFS
vfs SessionState
s) (State VFS () -> VFS) -> State VFS () -> VFS
forall a b. (a -> b) -> a -> b
$ LogAction (StateT VFS Identity) (WithSeverity VfsLog)
-> TMessage 'Method_TextDocumentDidOpen -> State VFS ()
forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> TMessage 'Method_TextDocumentDidOpen -> m ()
openVFS LogAction (StateT VFS Identity) (WithSeverity VfsLog)
logger TMessage 'Method_TextDocumentDidOpen
TNotificationMessage 'Method_TextDocumentDidOpen
msg
              SessionState -> m SessionState
forall a. a -> m a
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 = newVFS }

        getParamsFromTextDocumentEdit :: TextDocumentEdit -> Maybe DidChangeTextDocumentParams
        getParamsFromTextDocumentEdit :: TextDocumentEdit -> Maybe DidChangeTextDocumentParams
getParamsFromTextDocumentEdit (TextDocumentEdit OptionalVersionedTextDocumentIdentifier
docId [TextEdit |? AnnotatedTextEdit]
edits) =
          VersionedTextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> DidChangeTextDocumentParams
DidChangeTextDocumentParams (VersionedTextDocumentIdentifier
 -> [TextDocumentContentChangeEvent] -> DidChangeTextDocumentParams)
-> Maybe VersionedTextDocumentIdentifier
-> Maybe
     ([TextDocumentContentChangeEvent] -> DidChangeTextDocumentParams)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OptionalVersionedTextDocumentIdentifier
docId OptionalVersionedTextDocumentIdentifier
-> Getting
     (First VersionedTextDocumentIdentifier)
     OptionalVersionedTextDocumentIdentifier
     VersionedTextDocumentIdentifier
-> Maybe VersionedTextDocumentIdentifier
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting
  (First VersionedTextDocumentIdentifier)
  OptionalVersionedTextDocumentIdentifier
  VersionedTextDocumentIdentifier
Prism'
  OptionalVersionedTextDocumentIdentifier
  VersionedTextDocumentIdentifier
_versionedTextDocumentIdentifier Maybe
  ([TextDocumentContentChangeEvent] -> DidChangeTextDocumentParams)
-> Maybe [TextDocumentContentChangeEvent]
-> Maybe DidChangeTextDocumentParams
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [TextDocumentContentChangeEvent]
-> Maybe [TextDocumentContentChangeEvent]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((TextEdit |? AnnotatedTextEdit) -> TextDocumentContentChangeEvent)
-> [TextEdit |? AnnotatedTextEdit]
-> [TextDocumentContentChangeEvent]
forall a b. (a -> b) -> [a] -> [b]
map (TextEdit |? AnnotatedTextEdit) -> TextDocumentContentChangeEvent
editToChangeEvent [TextEdit |? AnnotatedTextEdit]
edits)

        -- TODO: move somewhere reusable
        editToChangeEvent :: TextEdit |? AnnotatedTextEdit -> TextDocumentContentChangeEvent
        editToChangeEvent :: (TextEdit |? AnnotatedTextEdit) -> TextDocumentContentChangeEvent
editToChangeEvent (InR AnnotatedTextEdit
e) = (Rec
   (Extend "range" Range ('R '[])
    .+ (Extend "rangeLength" (Maybe UInt) ('R '[])
        .+ (("text" .== Text) .+ 'R '[])))
 |? Rec (("text" .== Text) .+ 'R '[]))
-> TextDocumentContentChangeEvent
TextDocumentContentChangeEvent ((Rec
    (Extend "range" Range ('R '[])
     .+ (Extend "rangeLength" (Maybe UInt) ('R '[])
         .+ (("text" .== Text) .+ 'R '[])))
  |? Rec (("text" .== Text) .+ 'R '[]))
 -> TextDocumentContentChangeEvent)
-> (Rec
      (Extend "range" Range ('R '[])
       .+ (Extend "rangeLength" (Maybe UInt) ('R '[])
           .+ (("text" .== Text) .+ 'R '[])))
    |? Rec (("text" .== Text) .+ 'R '[]))
-> TextDocumentContentChangeEvent
forall a b. (a -> b) -> a -> b
$ Rec
  (Extend "range" Range ('R '[])
   .+ (Extend "rangeLength" (Maybe UInt) ('R '[])
       .+ (("text" .== Text) .+ 'R '[])))
-> Rec
     (Extend "range" Range ('R '[])
      .+ (Extend "rangeLength" (Maybe UInt) ('R '[])
          .+ (("text" .== Text) .+ 'R '[])))
   |? Rec (("text" .== Text) .+ 'R '[])
forall a b. a -> a |? b
InL (Rec
   (Extend "range" Range ('R '[])
    .+ (Extend "rangeLength" (Maybe UInt) ('R '[])
        .+ (("text" .== Text) .+ 'R '[])))
 -> Rec
      (Extend "range" Range ('R '[])
       .+ (Extend "rangeLength" (Maybe UInt) ('R '[])
           .+ (("text" .== Text) .+ 'R '[])))
    |? Rec (("text" .== Text) .+ 'R '[]))
-> Rec
     (Extend "range" Range ('R '[])
      .+ (Extend "rangeLength" (Maybe UInt) ('R '[])
          .+ (("text" .== Text) .+ 'R '[])))
-> Rec
     (Extend "range" Range ('R '[])
      .+ (Extend "rangeLength" (Maybe UInt) ('R '[])
          .+ (("text" .== Text) .+ 'R '[])))
   |? Rec (("text" .== Text) .+ 'R '[])
forall a b. (a -> b) -> a -> b
$ Label "range"
#range Label "range" -> Range -> Rec (Extend "range" Range ('R '[]))
forall (l :: Symbol) a.
KnownSymbol l =>
Label l -> a -> Rec (l .== a)
.== (AnnotatedTextEdit
e AnnotatedTextEdit -> Getting Range AnnotatedTextEdit Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range AnnotatedTextEdit Range
forall s a. HasRange s a => Lens' s a
Lens' AnnotatedTextEdit Range
L.range) Rec ('R '["range" ':-> Range])
-> Rec ('R '["rangeLength" ':-> Maybe UInt])
-> Rec
     ('R '["range" ':-> Range] .+ 'R '["rangeLength" ':-> Maybe UInt])
forall (l :: Row (*)) (r :: Row (*)).
FreeForall l =>
Rec l -> Rec r -> Rec (l .+ r)
.+ Label "rangeLength"
#rangeLength Label "rangeLength"
-> Maybe UInt -> Rec (Extend "rangeLength" (Maybe UInt) ('R '[]))
forall (l :: Symbol) a.
KnownSymbol l =>
Label l -> a -> Rec (l .== a)
.== Maybe UInt
forall a. Maybe a
Nothing Rec
  ('R '["range" ':-> Range] .+ 'R '["rangeLength" ':-> Maybe UInt])
-> Rec ('R '["text" ':-> Text])
-> Rec
     (('R '["range" ':-> Range] .+ 'R '["rangeLength" ':-> Maybe UInt])
      .+ 'R '["text" ':-> Text])
forall (l :: Row (*)) (r :: Row (*)).
FreeForall l =>
Rec l -> Rec r -> Rec (l .+ r)
.+ Label "text"
#text Label "text" -> Text -> Rec ("text" .== Text)
forall (l :: Symbol) a.
KnownSymbol l =>
Label l -> a -> Rec (l .== a)
.== (AnnotatedTextEdit
e AnnotatedTextEdit -> Getting Text AnnotatedTextEdit Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text AnnotatedTextEdit Text
forall s a. HasNewText s a => Lens' s a
Lens' AnnotatedTextEdit Text
L.newText)
        editToChangeEvent (InL TextEdit
e) = (Rec
   (Extend "range" Range ('R '[])
    .+ (Extend "rangeLength" (Maybe UInt) ('R '[])
        .+ (("text" .== Text) .+ 'R '[])))
 |? Rec (("text" .== Text) .+ 'R '[]))
-> TextDocumentContentChangeEvent
TextDocumentContentChangeEvent ((Rec
    (Extend "range" Range ('R '[])
     .+ (Extend "rangeLength" (Maybe UInt) ('R '[])
         .+ (("text" .== Text) .+ 'R '[])))
  |? Rec (("text" .== Text) .+ 'R '[]))
 -> TextDocumentContentChangeEvent)
-> (Rec
      (Extend "range" Range ('R '[])
       .+ (Extend "rangeLength" (Maybe UInt) ('R '[])
           .+ (("text" .== Text) .+ 'R '[])))
    |? Rec (("text" .== Text) .+ 'R '[]))
-> TextDocumentContentChangeEvent
forall a b. (a -> b) -> a -> b
$ Rec
  (Extend "range" Range ('R '[])
   .+ (Extend "rangeLength" (Maybe UInt) ('R '[])
       .+ (("text" .== Text) .+ 'R '[])))
-> Rec
     (Extend "range" Range ('R '[])
      .+ (Extend "rangeLength" (Maybe UInt) ('R '[])
          .+ (("text" .== Text) .+ 'R '[])))
   |? Rec (("text" .== Text) .+ 'R '[])
forall a b. a -> a |? b
InL (Rec
   (Extend "range" Range ('R '[])
    .+ (Extend "rangeLength" (Maybe UInt) ('R '[])
        .+ (("text" .== Text) .+ 'R '[])))
 -> Rec
      (Extend "range" Range ('R '[])
       .+ (Extend "rangeLength" (Maybe UInt) ('R '[])
           .+ (("text" .== Text) .+ 'R '[])))
    |? Rec (("text" .== Text) .+ 'R '[]))
-> Rec
     (Extend "range" Range ('R '[])
      .+ (Extend "rangeLength" (Maybe UInt) ('R '[])
          .+ (("text" .== Text) .+ 'R '[])))
-> Rec
     (Extend "range" Range ('R '[])
      .+ (Extend "rangeLength" (Maybe UInt) ('R '[])
          .+ (("text" .== Text) .+ 'R '[])))
   |? Rec (("text" .== Text) .+ 'R '[])
forall a b. (a -> b) -> a -> b
$ Label "range"
#range Label "range" -> Range -> Rec (Extend "range" Range ('R '[]))
forall (l :: Symbol) a.
KnownSymbol l =>
Label l -> a -> Rec (l .== a)
.== (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
Lens' TextEdit Range
L.range) Rec ('R '["range" ':-> Range])
-> Rec ('R '["rangeLength" ':-> Maybe UInt])
-> Rec
     ('R '["range" ':-> Range] .+ 'R '["rangeLength" ':-> Maybe UInt])
forall (l :: Row (*)) (r :: Row (*)).
FreeForall l =>
Rec l -> Rec r -> Rec (l .+ r)
.+ Label "rangeLength"
#rangeLength Label "rangeLength"
-> Maybe UInt -> Rec (Extend "rangeLength" (Maybe UInt) ('R '[]))
forall (l :: Symbol) a.
KnownSymbol l =>
Label l -> a -> Rec (l .== a)
.== Maybe UInt
forall a. Maybe a
Nothing Rec
  ('R '["range" ':-> Range] .+ 'R '["rangeLength" ':-> Maybe UInt])
-> Rec ('R '["text" ':-> Text])
-> Rec
     (('R '["range" ':-> Range] .+ 'R '["rangeLength" ':-> Maybe UInt])
      .+ 'R '["text" ':-> Text])
forall (l :: Row (*)) (r :: Row (*)).
FreeForall l =>
Rec l -> Rec r -> Rec (l .+ r)
.+ Label "text"
#text Label "text" -> Text -> Rec ("text" .== Text)
forall (l :: Symbol) a.
KnownSymbol l =>
Label l -> a -> Rec (l .== a)
.== (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
Lens' TextEdit Text
L.newText)

        getParamsFromDocumentChange :: DocumentChange -> Maybe DidChangeTextDocumentParams
        getParamsFromDocumentChange :: DocumentChange -> Maybe DidChangeTextDocumentParams
getParamsFromDocumentChange (InL TextDocumentEdit
textDocumentEdit) = TextDocumentEdit -> Maybe DidChangeTextDocumentParams
getParamsFromTextDocumentEdit TextDocumentEdit
textDocumentEdit
        getParamsFromDocumentChange DocumentChange
_ = Maybe DidChangeTextDocumentParams
forall a. Maybe a
Nothing

        bumpNewestVersion :: VersionedTextDocumentIdentifier
-> f VersionedTextDocumentIdentifier
bumpNewestVersion (VersionedTextDocumentIdentifier Uri
uri Int32
_) =
          [VersionedTextDocumentIdentifier]
-> VersionedTextDocumentIdentifier
forall a. HasCallStack => [a] -> a
head ([VersionedTextDocumentIdentifier]
 -> VersionedTextDocumentIdentifier)
-> f [VersionedTextDocumentIdentifier]
-> f VersionedTextDocumentIdentifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Uri -> f [VersionedTextDocumentIdentifier]
forall {m :: * -> *}.
HasState SessionState m =>
Uri -> m [VersionedTextDocumentIdentifier]
textDocumentVersions Uri
uri

        -- 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
          VFS
vfs <- 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
          let curVer :: Int32
curVer = Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
0 (Maybe Int32 -> Int32) -> Maybe Int32 -> Int32
forall a b. (a -> b) -> a -> b
$ VFS
vfs VFS -> Getting (First Int32) VFS Int32 -> Maybe Int32
forall s a. s -> Getting (First a) s a -> Maybe a
^? (Map NormalizedUri VirtualFile
 -> Const (First Int32) (Map NormalizedUri VirtualFile))
-> VFS -> Const (First Int32) VFS
forall s a. HasVfsMap s a => Lens' s a
Lens' VFS (Map NormalizedUri VirtualFile)
vfsMap ((Map NormalizedUri VirtualFile
  -> Const (First Int32) (Map NormalizedUri VirtualFile))
 -> VFS -> Const (First Int32) VFS)
-> ((Int32 -> Const (First Int32) Int32)
    -> Map NormalizedUri VirtualFile
    -> Const (First Int32) (Map NormalizedUri VirtualFile))
-> Getting (First Int32) VFS Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map NormalizedUri VirtualFile)
-> Traversal'
     (Map NormalizedUri VirtualFile)
     (IxValue (Map NormalizedUri VirtualFile))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (Uri -> NormalizedUri
toNormalizedUri Uri
uri) ((IxValue (Map NormalizedUri VirtualFile)
  -> Const (First Int32) (IxValue (Map NormalizedUri VirtualFile)))
 -> Map NormalizedUri VirtualFile
 -> Const (First Int32) (Map NormalizedUri VirtualFile))
-> ((Int32 -> Const (First Int32) Int32)
    -> IxValue (Map NormalizedUri VirtualFile)
    -> Const (First Int32) (IxValue (Map NormalizedUri VirtualFile)))
-> (Int32 -> Const (First Int32) Int32)
-> Map NormalizedUri VirtualFile
-> Const (First Int32) (Map NormalizedUri VirtualFile)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int32 -> Const (First Int32) Int32)
-> IxValue (Map NormalizedUri VirtualFile)
-> Const (First Int32) (IxValue (Map NormalizedUri VirtualFile))
forall s a. HasLsp_version s a => Lens' s a
Lens' (IxValue (Map NormalizedUri VirtualFile)) Int32
lsp_version
          [VersionedTextDocumentIdentifier]
-> m [VersionedTextDocumentIdentifier]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([VersionedTextDocumentIdentifier]
 -> m [VersionedTextDocumentIdentifier])
-> [VersionedTextDocumentIdentifier]
-> m [VersionedTextDocumentIdentifier]
forall a b. (a -> b) -> a -> b
$ (Int32 -> VersionedTextDocumentIdentifier)
-> [Int32] -> [VersionedTextDocumentIdentifier]
forall a b. (a -> b) -> [a] -> [b]
map (Uri -> Int32 -> VersionedTextDocumentIdentifier
VersionedTextDocumentIdentifier Uri
uri) [Int32
curVer Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
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 a. a -> m a
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) -> OptionalVersionedTextDocumentIdentifier
-> [TextEdit |? AnnotatedTextEdit] -> TextDocumentEdit
TextDocumentEdit (AReview
  OptionalVersionedTextDocumentIdentifier
  VersionedTextDocumentIdentifier
-> VersionedTextDocumentIdentifier
-> OptionalVersionedTextDocumentIdentifier
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview
  OptionalVersionedTextDocumentIdentifier
  VersionedTextDocumentIdentifier
Prism'
  OptionalVersionedTextDocumentIdentifier
  VersionedTextDocumentIdentifier
_versionedTextDocumentIdentifier VersionedTextDocumentIdentifier
v) [TextEdit -> TextEdit |? AnnotatedTextEdit
forall a b. a -> a |? b
InL 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 -> [TextEdit] -> m [DidChangeTextDocumentParams]
getChangeParams Uri
uri [TextEdit]
edits = do
          [TextDocumentEdit]
edits <- Uri -> [TextEdit] -> m [TextDocumentEdit]
forall {m :: * -> *}.
HasState SessionState m =>
Uri -> [TextEdit] -> m [TextDocumentEdit]
textDocumentEdits Uri
uri ([TextEdit] -> [TextEdit]
forall a. [a] -> [a]
reverse [TextEdit]
edits)
          [DidChangeTextDocumentParams] -> m [DidChangeTextDocumentParams]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([DidChangeTextDocumentParams] -> m [DidChangeTextDocumentParams])
-> [DidChangeTextDocumentParams] -> m [DidChangeTextDocumentParams]
forall a b. (a -> b) -> a -> b
$ [Maybe DidChangeTextDocumentParams]
-> [DidChangeTextDocumentParams]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe DidChangeTextDocumentParams]
 -> [DidChangeTextDocumentParams])
-> [Maybe DidChangeTextDocumentParams]
-> [DidChangeTextDocumentParams]
forall a b. (a -> b) -> a -> b
$ (TextDocumentEdit -> Maybe DidChangeTextDocumentParams)
-> [TextDocumentEdit] -> [Maybe DidChangeTextDocumentParams]
forall a b. (a -> b) -> [a] -> [b]
map TextDocumentEdit -> Maybe DidChangeTextDocumentParams
getParamsFromTextDocumentEdit [TextDocumentEdit]
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 a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((DidChangeTextDocumentParams -> [TextDocumentContentChangeEvent])
-> [DidChangeTextDocumentParams]
-> [[TextDocumentContentChangeEvent]]
forall a b. (a -> b) -> [a] -> [b]
map ([TextDocumentContentChangeEvent]
-> [TextDocumentContentChangeEvent]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ([TextDocumentContentChangeEvent]
 -> [TextDocumentContentChangeEvent])
-> (DidChangeTextDocumentParams
    -> [TextDocumentContentChangeEvent])
-> DidChangeTextDocumentParams
-> [TextDocumentContentChangeEvent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DidChangeTextDocumentParams
-> Getting
     [TextDocumentContentChangeEvent]
     DidChangeTextDocumentParams
     [TextDocumentContentChangeEvent]
-> [TextDocumentContentChangeEvent]
forall s a. s -> Getting a s a -> a
^. Getting
  [TextDocumentContentChangeEvent]
  DidChangeTextDocumentParams
  [TextDocumentContentChangeEvent]
forall s a. HasContentChanges s a => Lens' s a
Lens' DidChangeTextDocumentParams [TextDocumentContentChangeEvent]
L.contentChanges)) [DidChangeTextDocumentParams]
params))
                              in VersionedTextDocumentIdentifier
-> [TextDocumentContentChangeEvent] -> DidChangeTextDocumentParams
DidChangeTextDocumentParams ([DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
forall a. HasCallStack => [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
Lens' DidChangeTextDocumentParams VersionedTextDocumentIdentifier
L.textDocument) [TextDocumentContentChangeEvent]
events
updateState FromServerMessage
_ = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
sendMessage :: forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
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 a. IO a -> m a
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) IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (SessionException -> IO ()
forall a e. Exception e => e -> a
throw (SessionException -> IO ())
-> (IOError -> SessionException) -> IOError -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> IOError -> SessionException
MessageSendError (a -> Value
forall a. ToJSON a => a -> Value
toJSON a
msg))

-- | Execute a block f that will throw a 'Language.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 :: forall a. Int -> Session a -> Session a
withTimeout Int
duration Session a
f = do
  Chan SessionMessage
chan <- (SessionContext -> Chan SessionMessage)
-> Session (Chan SessionMessage)
forall b. (SessionContext -> b) -> Session b
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 = True }
  ThreadId
tid <- IO ThreadId -> Session ThreadId
forall a. IO a -> Session a
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
  IO () -> Session ()
forall a. IO a -> Session a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Session ()) -> IO () -> Session ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> IO ()
killThread ThreadId
tid
  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 = False }
  a -> Session a
forall a. 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
$c== :: LogMsgType -> LogMsgType -> Bool
== :: LogMsgType -> LogMsgType -> Bool
$c/= :: LogMsgType -> LogMsgType -> Bool
/= :: LogMsgType -> LogMsgType -> Bool
Eq

-- | Logs the message if the config specified it
logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m)
       => LogMsgType -> a -> m ()
logMsg :: forall a (m :: * -> *).
(ToJSON a, MonadIO m, HasReader SessionContext m) =>
LogMsgType -> a -> m ()
logMsg LogMsgType
t a
msg = do
  Bool
shouldLog <- (SessionContext -> Bool) -> m Bool
forall b. (SessionContext -> b) -> m b
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 b. (SessionContext -> b) -> m b
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 a. IO a -> m a
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