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

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.Except
#if __GLASGOW_HASKELL__ == 806
import Control.Monad.Fail
#endif
import Control.Monad.Trans.Class
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)
import Data.Aeson.Encode.Pretty
import Data.Conduit as Conduit
import Data.Conduit.Parser as Parser
import Data.Default
import Data.Foldable
import Data.List
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe
import Data.Function
import Language.LSP.Types.Capabilities
import Language.LSP.Types
import Language.LSP.Types.Lens
import qualified Language.LSP.Types.Lens 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 (..))

-- | 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 (a -> Session b -> Session a
(a -> b) -> Session a -> Session b
(forall a b. (a -> b) -> Session a -> Session b)
-> (forall a b. a -> Session b -> Session a) -> Functor Session
forall a b. a -> Session b -> Session a
forall a b. (a -> b) -> Session a -> Session b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Session b -> Session a
$c<$ :: forall a b. a -> Session b -> Session a
fmap :: (a -> b) -> Session a -> Session b
$cfmap :: forall a b. (a -> b) -> Session a -> Session b
Functor, Functor Session
a -> Session a
Functor Session
-> (forall a. a -> Session a)
-> (forall a b. Session (a -> b) -> Session a -> Session b)
-> (forall a b c.
    (a -> b -> c) -> Session a -> Session b -> Session c)
-> (forall a b. Session a -> Session b -> Session b)
-> (forall a b. Session a -> Session b -> Session a)
-> Applicative Session
Session a -> Session b -> Session b
Session a -> Session b -> Session a
Session (a -> b) -> Session a -> Session b
(a -> b -> c) -> Session a -> Session b -> Session c
forall a. a -> Session a
forall a b. Session a -> Session b -> Session a
forall a b. Session a -> Session b -> Session b
forall a b. Session (a -> b) -> Session a -> Session b
forall a b c. (a -> b -> c) -> Session a -> Session b -> Session c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Session a -> Session b -> Session a
$c<* :: forall a b. Session a -> Session b -> Session a
*> :: Session a -> Session b -> Session b
$c*> :: forall a b. Session a -> Session b -> Session b
liftA2 :: (a -> b -> c) -> Session a -> Session b -> Session c
$cliftA2 :: forall a b c. (a -> b -> c) -> Session a -> Session b -> Session c
<*> :: Session (a -> b) -> Session a -> Session b
$c<*> :: forall a b. Session (a -> b) -> Session a -> Session b
pure :: a -> Session a
$cpure :: forall a. a -> Session a
$cp1Applicative :: Functor Session
Applicative, Applicative Session
a -> Session a
Applicative Session
-> (forall a b. Session a -> (a -> Session b) -> Session b)
-> (forall a b. Session a -> Session b -> Session b)
-> (forall a. a -> Session a)
-> Monad Session
Session a -> (a -> Session b) -> Session b
Session a -> Session b -> Session b
forall a. a -> Session a
forall a b. Session a -> Session b -> Session b
forall a b. Session a -> (a -> Session b) -> Session b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Session a
$creturn :: forall a. a -> Session a
>> :: Session a -> Session b -> Session b
$c>> :: forall a b. Session a -> Session b -> Session b
>>= :: Session a -> (a -> Session b) -> Session b
$c>>= :: forall a b. Session a -> (a -> Session b) -> Session b
$cp1Monad :: Applicative Session
Monad, Monad Session
Monad Session -> (forall a. IO a -> Session a) -> MonadIO Session
IO a -> Session a
forall a. IO a -> Session a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> Session a
$cliftIO :: forall a. IO a -> Session a
$cp1MonadIO :: Monad Session
MonadIO, Applicative Session
Session a
Applicative Session
-> (forall a. Session a)
-> (forall a. Session a -> Session a -> Session a)
-> (forall a. Session a -> Session [a])
-> (forall a. Session a -> Session [a])
-> Alternative Session
Session a -> Session a -> Session a
Session a -> Session [a]
Session a -> Session [a]
forall a. Session a
forall a. Session a -> Session [a]
forall a. Session a -> Session a -> Session a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
many :: Session a -> Session [a]
$cmany :: forall a. Session a -> Session [a]
some :: Session a -> Session [a]
$csome :: forall a. Session a -> Session [a]
<|> :: Session a -> Session a -> Session a
$c<|> :: forall a. Session a -> Session a -> Session a
empty :: Session a
$cempty :: forall a. Session a
$cp1Alternative :: Applicative Session
Alternative)

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

-- | Stuff you can configure for a 'Session'.
data SessionConfig = SessionConfig
  { SessionConfig -> Int
messageTimeout :: Int  -- ^ Maximum time to wait for a message in seconds, defaults to 60.
  , SessionConfig -> Bool
logStdErr      :: Bool
  -- ^ Redirect the server's stderr to this stdout, defaults to False.
  -- Can be overriden with @LSP_TEST_LOG_STDERR@.
  , SessionConfig -> Bool
logMessages    :: Bool
  -- ^ Trace the messages sent and received to stdout, defaults to False.
  -- Can be overriden with the environment variable @LSP_TEST_LOG_MESSAGES@.
  , SessionConfig -> Bool
logColor       :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.
  , SessionConfig -> Maybe Value
lspConfig      :: Maybe Value -- ^ The initial LSP config as JSON value, defaults to Nothing.
  , SessionConfig -> Bool
ignoreLogNotifications :: Bool
  -- ^ Whether or not to ignore 'Language.LSP.Types.ShowMessageNotification' and
  -- 'Language.LSP.Types.LogMessageNotification', defaults to False.
  --
  -- @since 0.9.0.0
  , 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
-> Maybe Value
-> Bool
-> Maybe [WorkspaceFolder]
-> SessionConfig
SessionConfig Int
60 Bool
False Bool
False Bool
True Maybe Value
forall a. Maybe a
Nothing Bool
False 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
showList :: [SessionMessage] -> ShowS
$cshowList :: [SessionMessage] -> ShowS
show :: SessionMessage -> String
$cshow :: SessionMessage -> String
showsPrec :: Int -> SessionMessage -> ShowS
$cshowsPrec :: Int -> SessionMessage -> ShowS
Show

data SessionContext = SessionContext
  {
    SessionContext -> Handle
serverIn :: Handle
  , SessionContext -> String
rootDir :: FilePath
  , SessionContext -> Chan SessionMessage
messageChan :: Chan SessionMessage -- ^ Where all messages come through
  -- Keep curTimeoutId in SessionContext, as its tied to messageChan
  , SessionContext -> IORef Int
curTimeoutId :: IORef Int -- ^ The current timeout we are waiting on
  , SessionContext -> MVar RequestMap
requestMap :: MVar RequestMap
  , SessionContext -> MVar (ResponseMessage 'Initialize)
initRsp :: MVar (ResponseMessage 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 (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT SessionState (ReaderT SessionContext IO) SessionContext
 -> ConduitParser
      FromServerMessage
      (StateT SessionState (ReaderT SessionContext IO))
      SessionContext)
-> StateT SessionState (ReaderT SessionContext IO) SessionContext
-> ConduitParser
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     SessionContext
forall a b. (a -> b) -> a -> b
$ ReaderT SessionContext IO SessionContext
-> StateT SessionState (ReaderT SessionContext IO) SessionContext
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT SessionContext IO SessionContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
Reader.ask)

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

getCurTimeoutId :: (HasReader SessionContext m, MonadIO m) => m Int
getCurTimeoutId :: m Int
getCurTimeoutId = (SessionContext -> IORef Int) -> m (IORef Int)
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> (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 :: Int -> m ()
bumpTimeoutId Int
prev = do
  IORef Int
v <- (SessionContext -> IORef Int) -> m (IORef Int)
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 (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 -> Set ProgressToken
curProgressSessions :: !(Set.Set ProgressToken)
  }

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

  put :: s -> m ()

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

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

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

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

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

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

runSessionMonad :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
runSessionMonad :: 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))
  ()
-> ConduitM
     SessionMessage
     Void
     (StateT SessionState (ReaderT SessionContext IO))
     a
-> ConduitT
     () Void (StateT SessionState (ReaderT SessionContext IO)) a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM
  SessionMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
watchdog ConduitM
  SessionMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
-> ConduitM
     FromServerMessage
     Void
     (StateT SessionState (ReaderT SessionContext IO))
     a
-> ConduitM
     SessionMessage
     Void
     (StateT SessionState (ReaderT SessionContext IO))
     a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM
  FromServerMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
updateStateC ConduitM
  FromServerMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
-> ConduitM
     FromServerMessage
     Void
     (StateT SessionState (ReaderT SessionContext IO))
     a
-> ConduitM
     FromServerMessage
     Void
     (StateT SessionState (ReaderT SessionContext IO))
     a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitParser
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  a
-> ConduitM
     FromServerMessage
     Void
     (StateT SessionState (ReaderT SessionContext IO))
     a
forall (m :: * -> *) i a.
MonadThrow m =>
ConduitParser i m a -> ConduitT i Void m a
runConduitParser (ConduitParser
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  a
-> (ConduitParserException
    -> ConduitParser
         FromServerMessage
         (StateT SessionState (ReaderT SessionContext IO))
         a)
-> ConduitParser
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ConduitParser
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  a
session ConduitParserException
-> ConduitParser
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     a
forall (m :: * -> *) i b.
(HasState SessionState m, MonadIO m) =>
ConduitParserException -> ConduitParser i m b
handler)

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

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

    chanSource :: ConduitT
  ()
  SessionMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
chanSource = do
      SessionMessage
msg <- IO SessionMessage
-> ConduitT
     ()
     SessionMessage
     (StateT SessionState (ReaderT SessionContext IO))
     SessionMessage
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)
      Bool
-> ConduitT
     ()
     SessionMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
-> ConduitT
     ()
     SessionMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SessionConfig -> Bool
ignoreLogNotifications (SessionContext -> SessionConfig
config SessionContext
context) Bool -> Bool -> Bool
&& SessionMessage -> Bool
isLogNotification SessionMessage
msg) (ConduitT
   ()
   SessionMessage
   (StateT SessionState (ReaderT SessionContext IO))
   ()
 -> ConduitT
      ()
      SessionMessage
      (StateT SessionState (ReaderT SessionContext IO))
      ())
-> ConduitT
     ()
     SessionMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
-> ConduitT
     ()
     SessionMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall a b. (a -> b) -> a -> b
$
        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

    isLogNotification :: SessionMessage -> Bool
isLogNotification (ServerMessage (FromServerMess SMethod m
SWindowShowMessage Message m
_)) = Bool
True
    isLogNotification (ServerMessage (FromServerMess SMethod m
SWindowLogMessage Message m
_)) = Bool
True
    isLogNotification (ServerMessage (FromServerMess SMethod m
SWindowShowDocument Message m
_)) = Bool
True
    isLogNotification SessionMessage
_ = Bool
False

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

-- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
-- It also does not automatically send initialize and exit messages.
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' :: 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 (ResponseMessage 'Initialize)
initRsp <- IO (MVar (ResponseMessage '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 (ResponseMessage 'Initialize)
-> SessionConfig
-> ClientCapabilities
-> SessionContext
SessionContext Handle
serverIn String
absRootDir Chan SessionMessage
messageChan IORef Int
timeoutIdVar MVar RequestMap
reqMap MVar (ResponseMessage 'Initialize)
initRsp SessionConfig
config ClientCapabilities
caps
      initState :: VFS -> SessionState
initState VFS
vfs = Int32
-> VFS
-> Map NormalizedUri [Diagnostic]
-> Bool
-> Maybe FromServerMessage
-> Map Text SomeRegistration
-> Set ProgressToken
-> SessionState
SessionState Int32
0 VFS
vfs 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 Set ProgressToken
forall a. Monoid a => a
mempty
      runSession' :: Session () -> IO ((), SessionState)
runSession' Session ()
ses = (VFS -> IO ((), SessionState)) -> IO ((), SessionState)
forall r. (VFS -> IO r) -> IO r
initVFS ((VFS -> IO ((), SessionState)) -> IO ((), SessionState))
-> (VFS -> IO ((), SessionState)) -> IO ((), SessionState)
forall a b. (a -> b) -> a -> b
$ \VFS
vfs -> SessionContext
-> SessionState -> Session () -> IO ((), SessionState)
forall a.
SessionContext -> SessionState -> Session a -> IO (a, SessionState)
runSessionMonad SessionContext
context (VFS -> SessionState
initState VFS
vfs) Session ()
ses

      errorHandler :: SessionException -> IO ()
errorHandler = ThreadId -> SessionException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
mainThreadId :: SessionException -> IO ()
      serverListenerLauncher :: IO ThreadId
serverListenerLauncher =
        IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> (SessionException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Handle -> SessionContext -> IO ()
serverHandler Handle
serverOut SessionContext
context) SessionException -> IO ()
errorHandler
      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 (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 (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
$ (VFS -> IO (a, SessionState)) -> IO (a, SessionState)
forall r. (VFS -> IO r) -> IO r
initVFS ((VFS -> IO (a, SessionState)) -> IO (a, SessionState))
-> (VFS -> IO (a, SessionState)) -> IO (a, SessionState)
forall a b. (a -> b) -> a -> b
$ \VFS
vfs -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
forall a.
SessionContext -> SessionState -> Session a -> IO (a, SessionState)
runSessionMonad SessionContext
context (VFS -> SessionState
initState VFS
vfs) Session a
session)
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
updateStateC :: ConduitM
  FromServerMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
updateStateC = (FromServerMessage
 -> ConduitM
      FromServerMessage
      FromServerMessage
      (StateT SessionState (ReaderT SessionContext IO))
      ())
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever ((FromServerMessage
  -> ConduitM
       FromServerMessage
       FromServerMessage
       (StateT SessionState (ReaderT SessionContext IO))
       ())
 -> ConduitM
      FromServerMessage
      FromServerMessage
      (StateT SessionState (ReaderT SessionContext IO))
      ())
-> (FromServerMessage
    -> ConduitM
         FromServerMessage
         FromServerMessage
         (StateT SessionState (ReaderT SessionContext IO))
         ())
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall a b. (a -> b) -> a -> b
$ \FromServerMessage
msg -> do
  FromServerMessage
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (m :: * -> *).
(MonadIO m, HasReader SessionContext m, HasState SessionState m) =>
FromServerMessage -> m ()
updateState FromServerMessage
msg
  FromServerMessage
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (m :: * -> *).
(MonadIO m, HasReader SessionContext m) =>
FromServerMessage -> m ()
respond FromServerMessage
msg
  FromServerMessage
-> ConduitM
     FromServerMessage
     FromServerMessage
     (StateT SessionState (ReaderT SessionContext IO))
     ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield FromServerMessage
msg
  where
    respond :: (MonadIO m, HasReader SessionContext m) => FromServerMessage -> m ()
    respond :: FromServerMessage -> m ()
respond (FromServerMess SMethod m
SWindowWorkDoneProgressCreate Message m
req) =
      ResponseMessage 'WindowWorkDoneProgressCreate -> m ()
forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage (ResponseMessage 'WindowWorkDoneProgressCreate -> m ())
-> ResponseMessage 'WindowWorkDoneProgressCreate -> m ()
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe (LspId 'WindowWorkDoneProgressCreate)
-> Either
     ResponseError (ResponseResult 'WindowWorkDoneProgressCreate)
-> ResponseMessage 'WindowWorkDoneProgressCreate
forall (f :: From) (m :: Method f 'Request).
Text
-> Maybe (LspId m)
-> Either ResponseError (ResponseResult m)
-> ResponseMessage m
ResponseMessage Text
"2.0" (LspId 'WindowWorkDoneProgressCreate
-> Maybe (LspId 'WindowWorkDoneProgressCreate)
forall a. a -> Maybe a
Just (LspId 'WindowWorkDoneProgressCreate
 -> Maybe (LspId 'WindowWorkDoneProgressCreate))
-> LspId 'WindowWorkDoneProgressCreate
-> Maybe (LspId 'WindowWorkDoneProgressCreate)
forall a b. (a -> b) -> a -> b
$ Message m
RequestMessage 'WindowWorkDoneProgressCreate
req RequestMessage 'WindowWorkDoneProgressCreate
-> Getting
     (LspId 'WindowWorkDoneProgressCreate)
     (RequestMessage 'WindowWorkDoneProgressCreate)
     (LspId 'WindowWorkDoneProgressCreate)
-> LspId 'WindowWorkDoneProgressCreate
forall s a. s -> Getting a s a -> a
^. Getting
  (LspId 'WindowWorkDoneProgressCreate)
  (RequestMessage 'WindowWorkDoneProgressCreate)
  (LspId 'WindowWorkDoneProgressCreate)
forall s a. HasId s a => Lens' s a
LSP.id) (Empty -> Either ResponseError Empty
forall a b. b -> Either a b
Right Empty
Empty)
    respond (FromServerMess SMethod m
SWorkspaceApplyEdit Message m
r) = do
      ResponseMessage 'WorkspaceApplyEdit -> m ()
forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage (ResponseMessage 'WorkspaceApplyEdit -> m ())
-> ResponseMessage 'WorkspaceApplyEdit -> m ()
forall a b. (a -> b) -> a -> b
$ Text
-> Maybe (LspId 'WorkspaceApplyEdit)
-> Either ResponseError (ResponseResult 'WorkspaceApplyEdit)
-> ResponseMessage 'WorkspaceApplyEdit
forall (f :: From) (m :: Method f 'Request).
Text
-> Maybe (LspId m)
-> Either ResponseError (ResponseResult m)
-> ResponseMessage m
ResponseMessage Text
"2.0" (LspId 'WorkspaceApplyEdit -> Maybe (LspId 'WorkspaceApplyEdit)
forall a. a -> Maybe a
Just (LspId 'WorkspaceApplyEdit -> Maybe (LspId 'WorkspaceApplyEdit))
-> LspId 'WorkspaceApplyEdit -> Maybe (LspId 'WorkspaceApplyEdit)
forall a b. (a -> b) -> a -> b
$ Message m
RequestMessage 'WorkspaceApplyEdit
r RequestMessage 'WorkspaceApplyEdit
-> Getting
     (LspId 'WorkspaceApplyEdit)
     (RequestMessage 'WorkspaceApplyEdit)
     (LspId 'WorkspaceApplyEdit)
-> LspId 'WorkspaceApplyEdit
forall s a. s -> Getting a s a -> a
^. Getting
  (LspId 'WorkspaceApplyEdit)
  (RequestMessage 'WorkspaceApplyEdit)
  (LspId 'WorkspaceApplyEdit)
forall s a. HasId s a => Lens' s a
LSP.id) (ApplyWorkspaceEditResponseBody
-> Either ResponseError ApplyWorkspaceEditResponseBody
forall a b. b -> Either a b
Right (ApplyWorkspaceEditResponseBody
 -> Either ResponseError ApplyWorkspaceEditResponseBody)
-> ApplyWorkspaceEditResponseBody
-> Either ResponseError ApplyWorkspaceEditResponseBody
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Text -> Maybe UInt -> ApplyWorkspaceEditResponseBody
ApplyWorkspaceEditResponseBody Bool
True Maybe Text
forall a. Maybe a
Nothing Maybe UInt
forall a. Maybe a
Nothing)
    respond FromServerMessage
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- 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
^. (VersionedTextDocumentIdentifier
 -> Const Uri VersionedTextDocumentIdentifier)
-> TextDocumentEdit -> Const Uri TextDocumentEdit
forall s a. HasTextDocument s a => Lens' s a
textDocument ((VersionedTextDocumentIdentifier
  -> Const Uri VersionedTextDocumentIdentifier)
 -> TextDocumentEdit -> Const Uri TextDocumentEdit)
-> ((Uri -> Const Uri Uri)
    -> VersionedTextDocumentIdentifier
    -> Const Uri VersionedTextDocumentIdentifier)
-> Getting Uri TextDocumentEdit Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> VersionedTextDocumentIdentifier
-> Const Uri VersionedTextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
uri
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
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
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
uri

updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
            => FromServerMessage -> m ()
updateState :: FromServerMessage -> m ()
updateState (FromServerMess SMethod m
SProgress Message m
req) = case Message m
NotificationMessage 'Progress
req NotificationMessage 'Progress
-> Getting
     SomeProgressParams
     (NotificationMessage 'Progress)
     SomeProgressParams
-> SomeProgressParams
forall s a. s -> Getting a s a -> a
^. (ProgressParams SomeProgressParams
 -> Const SomeProgressParams (ProgressParams SomeProgressParams))
-> NotificationMessage 'Progress
-> Const SomeProgressParams (NotificationMessage 'Progress)
forall s a. HasParams s a => Lens' s a
params ((ProgressParams SomeProgressParams
  -> Const SomeProgressParams (ProgressParams SomeProgressParams))
 -> NotificationMessage 'Progress
 -> Const SomeProgressParams (NotificationMessage 'Progress))
-> ((SomeProgressParams
     -> Const SomeProgressParams SomeProgressParams)
    -> ProgressParams SomeProgressParams
    -> Const SomeProgressParams (ProgressParams SomeProgressParams))
-> Getting
     SomeProgressParams
     (NotificationMessage 'Progress)
     SomeProgressParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomeProgressParams -> Const SomeProgressParams SomeProgressParams)
-> ProgressParams SomeProgressParams
-> Const SomeProgressParams (ProgressParams SomeProgressParams)
forall s a. HasValue s a => Lens' s a
value of
  Begin WorkDoneProgressBeginParams
_ ->
    (SessionState -> SessionState) -> m ()
forall s (m :: * -> *). HasState s m => (s -> s) -> m ()
modify ((SessionState -> SessionState) -> m ())
-> (SessionState -> SessionState) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionState
s -> SessionState
s { curProgressSessions :: Set ProgressToken
curProgressSessions = ProgressToken -> Set ProgressToken -> Set ProgressToken
forall a. Ord a => a -> Set a -> Set a
Set.insert (Message m
NotificationMessage 'Progress
req NotificationMessage 'Progress
-> Getting
     ProgressToken (NotificationMessage 'Progress) ProgressToken
-> ProgressToken
forall s a. s -> Getting a s a -> a
^. (ProgressParams SomeProgressParams
 -> Const ProgressToken (ProgressParams SomeProgressParams))
-> NotificationMessage 'Progress
-> Const ProgressToken (NotificationMessage 'Progress)
forall s a. HasParams s a => Lens' s a
params ((ProgressParams SomeProgressParams
  -> Const ProgressToken (ProgressParams SomeProgressParams))
 -> NotificationMessage 'Progress
 -> Const ProgressToken (NotificationMessage 'Progress))
-> ((ProgressToken -> Const ProgressToken ProgressToken)
    -> ProgressParams SomeProgressParams
    -> Const ProgressToken (ProgressParams SomeProgressParams))
-> Getting
     ProgressToken (NotificationMessage 'Progress) ProgressToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgressToken -> Const ProgressToken ProgressToken)
-> ProgressParams SomeProgressParams
-> Const ProgressToken (ProgressParams SomeProgressParams)
forall s a. HasToken s a => Lens' s a
token) (Set ProgressToken -> Set ProgressToken)
-> Set ProgressToken -> Set ProgressToken
forall a b. (a -> b) -> a -> b
$ SessionState -> Set ProgressToken
curProgressSessions SessionState
s }
  End WorkDoneProgressEndParams
_ ->
    (SessionState -> SessionState) -> m ()
forall s (m :: * -> *). HasState s m => (s -> s) -> m ()
modify ((SessionState -> SessionState) -> m ())
-> (SessionState -> SessionState) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionState
s -> SessionState
s { curProgressSessions :: Set ProgressToken
curProgressSessions = ProgressToken -> Set ProgressToken -> Set ProgressToken
forall a. Ord a => a -> Set a -> Set a
Set.delete (Message m
NotificationMessage 'Progress
req NotificationMessage 'Progress
-> Getting
     ProgressToken (NotificationMessage 'Progress) ProgressToken
-> ProgressToken
forall s a. s -> Getting a s a -> a
^. (ProgressParams SomeProgressParams
 -> Const ProgressToken (ProgressParams SomeProgressParams))
-> NotificationMessage 'Progress
-> Const ProgressToken (NotificationMessage 'Progress)
forall s a. HasParams s a => Lens' s a
params ((ProgressParams SomeProgressParams
  -> Const ProgressToken (ProgressParams SomeProgressParams))
 -> NotificationMessage 'Progress
 -> Const ProgressToken (NotificationMessage 'Progress))
-> ((ProgressToken -> Const ProgressToken ProgressToken)
    -> ProgressParams SomeProgressParams
    -> Const ProgressToken (ProgressParams SomeProgressParams))
-> Getting
     ProgressToken (NotificationMessage 'Progress) ProgressToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgressToken -> Const ProgressToken ProgressToken)
-> ProgressParams SomeProgressParams
-> Const ProgressToken (ProgressParams SomeProgressParams)
forall s a. HasToken s a => Lens' s a
token) (Set ProgressToken -> Set ProgressToken)
-> Set ProgressToken -> Set ProgressToken
forall a b. (a -> b) -> a -> b
$ SessionState -> Set ProgressToken
curProgressSessions SessionState
s }
  SomeProgressParams
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

updateState (FromServerMess SMethod m
SClientUnregisterCapability Message m
req) = do
  let List [Text]
unRegs = (Unregistration -> Getting Text Unregistration Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Unregistration Text
forall s a. HasId s a => Lens' s a
LSP.id) (Unregistration -> Text) -> List Unregistration -> List Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message m
RequestMessage 'ClientUnregisterCapability
req RequestMessage 'ClientUnregisterCapability
-> Getting
     (List Unregistration)
     (RequestMessage 'ClientUnregisterCapability)
     (List Unregistration)
-> List Unregistration
forall s a. s -> Getting a s a -> a
^. (UnregistrationParams
 -> Const (List Unregistration) UnregistrationParams)
-> RequestMessage 'ClientUnregisterCapability
-> Const
     (List Unregistration) (RequestMessage 'ClientUnregisterCapability)
forall s a. HasParams s a => Lens' s a
params ((UnregistrationParams
  -> Const (List Unregistration) UnregistrationParams)
 -> RequestMessage 'ClientUnregisterCapability
 -> Const
      (List Unregistration) (RequestMessage 'ClientUnregisterCapability))
-> ((List Unregistration
     -> Const (List Unregistration) (List Unregistration))
    -> UnregistrationParams
    -> Const (List Unregistration) UnregistrationParams)
-> Getting
     (List Unregistration)
     (RequestMessage 'ClientUnregisterCapability)
     (List Unregistration)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (List Unregistration
 -> Const (List Unregistration) (List Unregistration))
-> UnregistrationParams
-> Const (List Unregistration) UnregistrationParams
forall s a. HasUnregisterations s a => Lens' s a
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 (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 :: Map Text SomeRegistration
curDynCaps = Map Text SomeRegistration
newCurDynCaps }

updateState (FromServerMess SMethod m
STextDocumentPublishDiagnostics Message m
n) = do
  let List [Diagnostic]
diags = Message m
NotificationMessage 'TextDocumentPublishDiagnostics
n NotificationMessage 'TextDocumentPublishDiagnostics
-> Getting
     (List Diagnostic)
     (NotificationMessage 'TextDocumentPublishDiagnostics)
     (List Diagnostic)
-> List Diagnostic
forall s a. s -> Getting a s a -> a
^. (PublishDiagnosticsParams
 -> Const (List Diagnostic) PublishDiagnosticsParams)
-> NotificationMessage 'TextDocumentPublishDiagnostics
-> Const
     (List Diagnostic)
     (NotificationMessage 'TextDocumentPublishDiagnostics)
forall s a. HasParams s a => Lens' s a
params ((PublishDiagnosticsParams
  -> Const (List Diagnostic) PublishDiagnosticsParams)
 -> NotificationMessage 'TextDocumentPublishDiagnostics
 -> Const
      (List Diagnostic)
      (NotificationMessage 'TextDocumentPublishDiagnostics))
-> ((List Diagnostic -> Const (List Diagnostic) (List Diagnostic))
    -> PublishDiagnosticsParams
    -> Const (List Diagnostic) PublishDiagnosticsParams)
-> Getting
     (List Diagnostic)
     (NotificationMessage 'TextDocumentPublishDiagnostics)
     (List Diagnostic)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (List Diagnostic -> Const (List Diagnostic) (List Diagnostic))
-> PublishDiagnosticsParams
-> Const (List Diagnostic) PublishDiagnosticsParams
forall s a. HasDiagnostics s a => Lens' s a
diagnostics
      doc :: Uri
doc = Message m
NotificationMessage 'TextDocumentPublishDiagnostics
n NotificationMessage 'TextDocumentPublishDiagnostics
-> Getting
     Uri (NotificationMessage 'TextDocumentPublishDiagnostics) Uri
-> Uri
forall s a. s -> Getting a s a -> a
^. (PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
-> NotificationMessage 'TextDocumentPublishDiagnostics
-> Const Uri (NotificationMessage 'TextDocumentPublishDiagnostics)
forall s a. HasParams s a => Lens' s a
params ((PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
 -> NotificationMessage 'TextDocumentPublishDiagnostics
 -> Const Uri (NotificationMessage 'TextDocumentPublishDiagnostics))
-> ((Uri -> Const Uri Uri)
    -> PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
-> Getting
     Uri (NotificationMessage '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
uri
  (SessionState -> SessionState) -> m ()
forall s (m :: * -> *). HasState s m => (s -> s) -> m ()
modify ((SessionState -> SessionState) -> m ())
-> (SessionState -> SessionState) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionState
s ->
    let newDiags :: Map NormalizedUri [Diagnostic]
newDiags = NormalizedUri
-> [Diagnostic]
-> Map NormalizedUri [Diagnostic]
-> Map NormalizedUri [Diagnostic]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Uri -> NormalizedUri
toNormalizedUri Uri
doc) [Diagnostic]
diags (SessionState -> Map NormalizedUri [Diagnostic]
curDiagnostics SessionState
s)
      in SessionState
s { curDiagnostics :: Map NormalizedUri [Diagnostic]
curDiagnostics = Map NormalizedUri [Diagnostic]
newDiags }

updateState (FromServerMess SMethod m
SWorkspaceApplyEdit Message m
r) = do

  -- First, prefer the versioned documentChanges field
  [DidChangeTextDocumentParams]
allChangeParams <- case Message m
RequestMessage 'WorkspaceApplyEdit
r RequestMessage 'WorkspaceApplyEdit
-> Getting
     (Maybe (List DocumentChange))
     (RequestMessage 'WorkspaceApplyEdit)
     (Maybe (List DocumentChange))
-> Maybe (List DocumentChange)
forall s a. s -> Getting a s a -> a
^. (ApplyWorkspaceEditParams
 -> Const (Maybe (List DocumentChange)) ApplyWorkspaceEditParams)
-> RequestMessage 'WorkspaceApplyEdit
-> Const
     (Maybe (List DocumentChange)) (RequestMessage 'WorkspaceApplyEdit)
forall s a. HasParams s a => Lens' s a
params ((ApplyWorkspaceEditParams
  -> Const (Maybe (List DocumentChange)) ApplyWorkspaceEditParams)
 -> RequestMessage 'WorkspaceApplyEdit
 -> Const
      (Maybe (List DocumentChange)) (RequestMessage 'WorkspaceApplyEdit))
-> ((Maybe (List DocumentChange)
     -> Const
          (Maybe (List DocumentChange)) (Maybe (List DocumentChange)))
    -> ApplyWorkspaceEditParams
    -> Const (Maybe (List DocumentChange)) ApplyWorkspaceEditParams)
-> Getting
     (Maybe (List DocumentChange))
     (RequestMessage 'WorkspaceApplyEdit)
     (Maybe (List DocumentChange))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WorkspaceEdit
 -> Const (Maybe (List DocumentChange)) WorkspaceEdit)
-> ApplyWorkspaceEditParams
-> Const (Maybe (List DocumentChange)) ApplyWorkspaceEditParams
forall s a. HasEdit s a => Lens' s a
edit ((WorkspaceEdit
  -> Const (Maybe (List DocumentChange)) WorkspaceEdit)
 -> ApplyWorkspaceEditParams
 -> Const (Maybe (List DocumentChange)) ApplyWorkspaceEditParams)
-> ((Maybe (List DocumentChange)
     -> Const
          (Maybe (List DocumentChange)) (Maybe (List DocumentChange)))
    -> WorkspaceEdit
    -> Const (Maybe (List DocumentChange)) WorkspaceEdit)
-> (Maybe (List DocumentChange)
    -> Const
         (Maybe (List DocumentChange)) (Maybe (List DocumentChange)))
-> ApplyWorkspaceEditParams
-> Const (Maybe (List DocumentChange)) ApplyWorkspaceEditParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (List DocumentChange)
 -> Const
      (Maybe (List DocumentChange)) (Maybe (List DocumentChange)))
-> WorkspaceEdit
-> Const (Maybe (List DocumentChange)) WorkspaceEdit
forall s a. HasDocumentChanges s a => Lens' s a
documentChanges of
    Just (List [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)
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 a1 b a2. Prism (a1 |? b) (a2 |? b) a1 a2
_InL ((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
. (VersionedTextDocumentIdentifier
 -> m VersionedTextDocumentIdentifier)
-> TextDocumentEdit -> m TextDocumentEdit
forall s a. HasTextDocument s a => Lens' s a
textDocument) VersionedTextDocumentIdentifier
-> m VersionedTextDocumentIdentifier
forall (f :: * -> *).
HasState SessionState f =>
VersionedTextDocumentIdentifier
-> f VersionedTextDocumentIdentifier
bumpNewestVersion [DocumentChange]
cs
      [DidChangeTextDocumentParams] -> m [DidChangeTextDocumentParams]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DidChangeTextDocumentParams] -> m [DidChangeTextDocumentParams])
-> [DidChangeTextDocumentParams] -> m [DidChangeTextDocumentParams]
forall a b. (a -> b) -> a -> b
$ (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 (List DocumentChange)
Nothing -> case Message m
RequestMessage 'WorkspaceApplyEdit
r RequestMessage 'WorkspaceApplyEdit
-> Getting
     (Maybe (HashMap Uri (List TextEdit)))
     (RequestMessage 'WorkspaceApplyEdit)
     (Maybe (HashMap Uri (List TextEdit)))
-> Maybe (HashMap Uri (List TextEdit))
forall s a. s -> Getting a s a -> a
^. (ApplyWorkspaceEditParams
 -> Const
      (Maybe (HashMap Uri (List TextEdit))) ApplyWorkspaceEditParams)
-> RequestMessage 'WorkspaceApplyEdit
-> Const
     (Maybe (HashMap Uri (List TextEdit)))
     (RequestMessage 'WorkspaceApplyEdit)
forall s a. HasParams s a => Lens' s a
params ((ApplyWorkspaceEditParams
  -> Const
       (Maybe (HashMap Uri (List TextEdit))) ApplyWorkspaceEditParams)
 -> RequestMessage 'WorkspaceApplyEdit
 -> Const
      (Maybe (HashMap Uri (List TextEdit)))
      (RequestMessage 'WorkspaceApplyEdit))
-> ((Maybe (HashMap Uri (List TextEdit))
     -> Const
          (Maybe (HashMap Uri (List TextEdit)))
          (Maybe (HashMap Uri (List TextEdit))))
    -> ApplyWorkspaceEditParams
    -> Const
         (Maybe (HashMap Uri (List TextEdit))) ApplyWorkspaceEditParams)
-> Getting
     (Maybe (HashMap Uri (List TextEdit)))
     (RequestMessage 'WorkspaceApplyEdit)
     (Maybe (HashMap Uri (List TextEdit)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WorkspaceEdit
 -> Const (Maybe (HashMap Uri (List TextEdit))) WorkspaceEdit)
-> ApplyWorkspaceEditParams
-> Const
     (Maybe (HashMap Uri (List TextEdit))) ApplyWorkspaceEditParams
forall s a. HasEdit s a => Lens' s a
edit ((WorkspaceEdit
  -> Const (Maybe (HashMap Uri (List TextEdit))) WorkspaceEdit)
 -> ApplyWorkspaceEditParams
 -> Const
      (Maybe (HashMap Uri (List TextEdit))) ApplyWorkspaceEditParams)
-> ((Maybe (HashMap Uri (List TextEdit))
     -> Const
          (Maybe (HashMap Uri (List TextEdit)))
          (Maybe (HashMap Uri (List TextEdit))))
    -> WorkspaceEdit
    -> Const (Maybe (HashMap Uri (List TextEdit))) WorkspaceEdit)
-> (Maybe (HashMap Uri (List TextEdit))
    -> Const
         (Maybe (HashMap Uri (List TextEdit)))
         (Maybe (HashMap Uri (List TextEdit))))
-> ApplyWorkspaceEditParams
-> Const
     (Maybe (HashMap Uri (List TextEdit))) ApplyWorkspaceEditParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (HashMap Uri (List TextEdit))
 -> Const
      (Maybe (HashMap Uri (List TextEdit)))
      (Maybe (HashMap Uri (List TextEdit))))
-> WorkspaceEdit
-> Const (Maybe (HashMap Uri (List TextEdit))) WorkspaceEdit
forall s a. HasChanges s a => Lens' s a
changes of
      Just HashMap Uri (List TextEdit)
cs -> do
        (Uri -> m ()) -> [Uri] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Uri -> m ()
checkIfNeedsOpened (HashMap Uri (List TextEdit) -> [Uri]
forall k v. HashMap k v -> [k]
HashMap.keys HashMap Uri (List TextEdit)
cs)
        [[DidChangeTextDocumentParams]] -> [DidChangeTextDocumentParams]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[DidChangeTextDocumentParams]] -> [DidChangeTextDocumentParams])
-> m [[DidChangeTextDocumentParams]]
-> m [DidChangeTextDocumentParams]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Uri, List TextEdit) -> m [DidChangeTextDocumentParams])
-> [(Uri, List TextEdit)] -> m [[DidChangeTextDocumentParams]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Uri -> List TextEdit -> m [DidChangeTextDocumentParams])
-> (Uri, List TextEdit) -> m [DidChangeTextDocumentParams]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Uri -> List TextEdit -> m [DidChangeTextDocumentParams]
forall (f :: * -> *).
HasState SessionState f =>
Uri -> List TextEdit -> f [DidChangeTextDocumentParams]
getChangeParams) (HashMap Uri (List TextEdit) -> [(Uri, List TextEdit)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Uri (List TextEdit)
cs)
      Maybe (HashMap Uri (List TextEdit))
Nothing ->
        String -> m [DidChangeTextDocumentParams]
forall a. HasCallStack => String -> a
error String
"WorkspaceEdit contains neither documentChanges nor changes!"

  (SessionState -> m SessionState) -> m ()
forall s (m :: * -> *).
(HasState s m, HasState s m, Monad m) =>
(s -> m s) -> m ()
modifyM ((SessionState -> m SessionState) -> m ())
-> (SessionState -> m SessionState) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionState
s -> do
    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)
-> Message 'WorkspaceApplyEdit -> State VFS ()
forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> Message 'WorkspaceApplyEdit -> m ()
changeFromServerVFS LogAction (StateT VFS Identity) (WithSeverity VfsLog)
logger Message m
Message 'WorkspaceApplyEdit
r
    SessionState -> m SessionState
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionState -> m SessionState) -> SessionState -> m SessionState
forall a b. (a -> b) -> a -> b
$ SessionState
s { vfs :: VFS
vfs = VFS
newVFS }

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

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

  -- Update VFS to new document versions
  let sortedVersions :: [[DidChangeTextDocumentParams]]
sortedVersions = ([DidChangeTextDocumentParams] -> [DidChangeTextDocumentParams])
-> [[DidChangeTextDocumentParams]]
-> [[DidChangeTextDocumentParams]]
forall a b. (a -> b) -> [a] -> [b]
map ((DidChangeTextDocumentParams
 -> DidChangeTextDocumentParams -> Ordering)
-> [DidChangeTextDocumentParams] -> [DidChangeTextDocumentParams]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (TextDocumentVersion -> TextDocumentVersion -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (TextDocumentVersion -> TextDocumentVersion -> Ordering)
-> (DidChangeTextDocumentParams -> TextDocumentVersion)
-> DidChangeTextDocumentParams
-> DidChangeTextDocumentParams
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (DidChangeTextDocumentParams
-> Getting
     TextDocumentVersion DidChangeTextDocumentParams TextDocumentVersion
-> TextDocumentVersion
forall s a. s -> Getting a s a -> a
^. (VersionedTextDocumentIdentifier
 -> Const TextDocumentVersion VersionedTextDocumentIdentifier)
-> DidChangeTextDocumentParams
-> Const TextDocumentVersion DidChangeTextDocumentParams
forall s a. HasTextDocument s a => Lens' s a
textDocument ((VersionedTextDocumentIdentifier
  -> Const TextDocumentVersion VersionedTextDocumentIdentifier)
 -> DidChangeTextDocumentParams
 -> Const TextDocumentVersion DidChangeTextDocumentParams)
-> ((TextDocumentVersion
     -> Const TextDocumentVersion TextDocumentVersion)
    -> VersionedTextDocumentIdentifier
    -> Const TextDocumentVersion VersionedTextDocumentIdentifier)
-> Getting
     TextDocumentVersion DidChangeTextDocumentParams TextDocumentVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentVersion
 -> Const TextDocumentVersion TextDocumentVersion)
-> VersionedTextDocumentIdentifier
-> Const TextDocumentVersion VersionedTextDocumentIdentifier
forall s a. HasVersion s a => Lens' s a
version))) [[DidChangeTextDocumentParams]]
groupedParams
      latestVersions :: [VersionedTextDocumentIdentifier]
latestVersions = ([DidChangeTextDocumentParams] -> VersionedTextDocumentIdentifier)
-> [[DidChangeTextDocumentParams]]
-> [VersionedTextDocumentIdentifier]
forall a b. (a -> b) -> [a] -> [b]
map ((DidChangeTextDocumentParams
-> Getting
     VersionedTextDocumentIdentifier
     DidChangeTextDocumentParams
     VersionedTextDocumentIdentifier
-> VersionedTextDocumentIdentifier
forall s a. s -> Getting a s a -> a
^. Getting
  VersionedTextDocumentIdentifier
  DidChangeTextDocumentParams
  VersionedTextDocumentIdentifier
forall s a. HasTextDocument s a => Lens' s a
textDocument) (DidChangeTextDocumentParams -> VersionedTextDocumentIdentifier)
-> ([DidChangeTextDocumentParams] -> DidChangeTextDocumentParams)
-> [DidChangeTextDocumentParams]
-> VersionedTextDocumentIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
forall a. [a] -> a
last) [[DidChangeTextDocumentParams]]
sortedVersions

  [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 TextDocumentVersion
v) ->
    (SessionState -> SessionState) -> m ()
forall s (m :: * -> *). HasState s m => (s -> s) -> m ()
modify ((SessionState -> SessionState) -> m ())
-> (SessionState -> SessionState) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionState
s ->
      let oldVFS :: VFS
oldVFS = SessionState -> VFS
vfs SessionState
s
          update :: VirtualFile -> VirtualFile
update (VirtualFile Int32
oldV Int
file_ver Rope
t) = Int32 -> Int -> Rope -> VirtualFile
VirtualFile (Int32 -> TextDocumentVersion -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
oldV TextDocumentVersion
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
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 :: VFS
vfs = 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 (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 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
vfsMap ((Map NormalizedUri VirtualFile
  -> Const Any (Map NormalizedUri VirtualFile))
 -> VFS -> Const Any VFS)
-> ((VirtualFile -> Const Any VirtualFile)
    -> Map NormalizedUri VirtualFile
    -> Const Any (Map NormalizedUri VirtualFile))
-> Getting Any VFS 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 (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 :: NotificationMessage 'TextDocumentDidOpen
msg = Text
-> SMethod 'TextDocumentDidOpen
-> MessageParams 'TextDocumentDidOpen
-> NotificationMessage 'TextDocumentDidOpen
forall (f :: From) (m :: Method f 'Notification).
Text -> SMethod m -> MessageParams m -> NotificationMessage m
NotificationMessage Text
"2.0" SMethod 'TextDocumentDidOpen
STextDocumentDidOpen (TextDocumentItem -> DidOpenTextDocumentParams
DidOpenTextDocumentParams TextDocumentItem
item)
            NotificationMessage 'TextDocumentDidOpen -> m ()
forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage NotificationMessage '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)
-> Message 'TextDocumentDidOpen -> State VFS ()
forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> Message 'TextDocumentDidOpen -> m ()
openVFS LogAction (StateT VFS Identity) (WithSeverity VfsLog)
logger Message 'TextDocumentDidOpen
NotificationMessage 'TextDocumentDidOpen
msg
              SessionState -> m SessionState
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionState -> m SessionState) -> SessionState -> m SessionState
forall a b. (a -> b) -> a -> b
$ SessionState
s { vfs :: VFS
vfs = VFS
newVFS }

        getParamsFromTextDocumentEdit :: TextDocumentEdit -> DidChangeTextDocumentParams
        getParamsFromTextDocumentEdit :: TextDocumentEdit -> DidChangeTextDocumentParams
getParamsFromTextDocumentEdit (TextDocumentEdit VersionedTextDocumentIdentifier
docId (List [TextEdit |? AnnotatedTextEdit]
edits)) = do
          VersionedTextDocumentIdentifier
-> List TextDocumentContentChangeEvent
-> DidChangeTextDocumentParams
DidChangeTextDocumentParams VersionedTextDocumentIdentifier
docId ([TextDocumentContentChangeEvent]
-> List TextDocumentContentChangeEvent
forall a. [a] -> List a
List ([TextDocumentContentChangeEvent]
 -> List TextDocumentContentChangeEvent)
-> [TextDocumentContentChangeEvent]
-> List TextDocumentContentChangeEvent
forall a b. (a -> b) -> a -> b
$ ((TextEdit |? AnnotatedTextEdit) -> TextDocumentContentChangeEvent)
-> [TextEdit |? AnnotatedTextEdit]
-> [TextDocumentContentChangeEvent]
forall a b. (a -> b) -> [a] -> [b]
map (TextEdit |? AnnotatedTextEdit) -> TextDocumentContentChangeEvent
editToChangeEvent [TextEdit |? AnnotatedTextEdit]
edits)

        editToChangeEvent :: TextEdit |? AnnotatedTextEdit -> TextDocumentContentChangeEvent
        editToChangeEvent :: (TextEdit |? AnnotatedTextEdit) -> TextDocumentContentChangeEvent
editToChangeEvent (InR AnnotatedTextEdit
e) = Maybe Range -> Maybe UInt -> Text -> TextDocumentContentChangeEvent
TextDocumentContentChangeEvent (Range -> Maybe Range
forall a. a -> Maybe a
Just (Range -> Maybe Range) -> Range -> Maybe Range
forall a b. (a -> b) -> a -> b
$ 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
range) Maybe UInt
forall a. Maybe a
Nothing (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
newText)
        editToChangeEvent (InL TextEdit
e) = Maybe Range -> Maybe UInt -> Text -> TextDocumentContentChangeEvent
TextDocumentContentChangeEvent (Range -> Maybe Range
forall a. a -> Maybe a
Just (Range -> Maybe Range) -> Range -> Maybe Range
forall a b. (a -> b) -> a -> b
$ TextEdit
e TextEdit -> Getting Range TextEdit Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range TextEdit Range
forall s a. HasRange s a => Lens' s a
range) Maybe UInt
forall a. Maybe a
Nothing (TextEdit
e TextEdit -> Getting Text TextEdit Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text TextEdit Text
forall s a. HasNewText s a => Lens' s a
newText)

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

        bumpNewestVersion :: VersionedTextDocumentIdentifier
-> f VersionedTextDocumentIdentifier
bumpNewestVersion (VersionedTextDocumentIdentifier Uri
uri TextDocumentVersion
_) =
          [VersionedTextDocumentIdentifier]
-> VersionedTextDocumentIdentifier
forall a. [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 -> TextDocumentVersion -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
0 (TextDocumentVersion -> Int32) -> TextDocumentVersion -> Int32
forall a b. (a -> b) -> a -> b
$ VFS
vfs VFS -> Getting (First Int32) VFS Int32 -> TextDocumentVersion
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
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) ((VirtualFile -> Const (First Int32) VirtualFile)
 -> Map NormalizedUri VirtualFile
 -> Const (First Int32) (Map NormalizedUri VirtualFile))
-> ((Int32 -> Const (First Int32) Int32)
    -> VirtualFile -> Const (First Int32) 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)
-> VirtualFile -> Const (First Int32) VirtualFile
forall s a. HasLsp_version s a => Lens' s a
lsp_version
          [VersionedTextDocumentIdentifier]
-> m [VersionedTextDocumentIdentifier]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([VersionedTextDocumentIdentifier]
 -> m [VersionedTextDocumentIdentifier])
-> [VersionedTextDocumentIdentifier]
-> m [VersionedTextDocumentIdentifier]
forall a b. (a -> b) -> a -> b
$ (Int32 -> VersionedTextDocumentIdentifier)
-> [Int32] -> [VersionedTextDocumentIdentifier]
forall a b. (a -> b) -> [a] -> [b]
map (Uri -> TextDocumentVersion -> VersionedTextDocumentIdentifier
VersionedTextDocumentIdentifier Uri
uri (TextDocumentVersion -> VersionedTextDocumentIdentifier)
-> (Int32 -> TextDocumentVersion)
-> Int32
-> VersionedTextDocumentIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> TextDocumentVersion
forall a. a -> Maybe a
Just) [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 (f :: * -> *) a. Applicative f => a -> f a
pure ([TextDocumentEdit] -> m [TextDocumentEdit])
-> [TextDocumentEdit] -> m [TextDocumentEdit]
forall a b. (a -> b) -> a -> b
$ ((VersionedTextDocumentIdentifier, TextEdit) -> TextDocumentEdit)
-> [(VersionedTextDocumentIdentifier, TextEdit)]
-> [TextDocumentEdit]
forall a b. (a -> b) -> [a] -> [b]
map (\(VersionedTextDocumentIdentifier
v, TextEdit
e) -> VersionedTextDocumentIdentifier
-> List (TextEdit |? AnnotatedTextEdit) -> TextDocumentEdit
TextDocumentEdit VersionedTextDocumentIdentifier
v ([TextEdit |? AnnotatedTextEdit]
-> List (TextEdit |? AnnotatedTextEdit)
forall a. [a] -> List a
List [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 -> List TextEdit -> f [DidChangeTextDocumentParams]
getChangeParams Uri
uri (List [TextEdit]
edits) = do
          (TextDocumentEdit -> DidChangeTextDocumentParams)
-> [TextDocumentEdit] -> [DidChangeTextDocumentParams]
forall a b. (a -> b) -> [a] -> [b]
map ((TextDocumentEdit -> DidChangeTextDocumentParams)
 -> [TextDocumentEdit] -> [DidChangeTextDocumentParams])
-> f (TextDocumentEdit -> DidChangeTextDocumentParams)
-> f ([TextDocumentEdit] -> [DidChangeTextDocumentParams])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TextDocumentEdit -> DidChangeTextDocumentParams)
-> f (TextDocumentEdit -> DidChangeTextDocumentParams)
forall (f :: * -> *) a. Applicative f => a -> f a
pure TextDocumentEdit -> DidChangeTextDocumentParams
getParamsFromTextDocumentEdit f ([TextDocumentEdit] -> [DidChangeTextDocumentParams])
-> f [TextDocumentEdit] -> f [DidChangeTextDocumentParams]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Uri -> [TextEdit] -> f [TextDocumentEdit]
forall (m :: * -> *).
HasState SessionState m =>
Uri -> [TextEdit] -> m [TextDocumentEdit]
textDocumentEdits Uri
uri ([TextEdit] -> [TextEdit]
forall a. [a] -> [a]
reverse [TextEdit]
edits)

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

sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
sendMessage :: a -> m ()
sendMessage a
msg = do
  Handle
h <- SessionContext -> Handle
serverIn (SessionContext -> Handle) -> m SessionContext -> m Handle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m SessionContext
forall r (m :: * -> *). HasReader r m => m r
ask
  LogMsgType -> a -> m ()
forall a (m :: * -> *).
(ToJSON a, MonadIO m, HasReader SessionContext m) =>
LogMsgType -> a -> m ()
logMsg LogMsgType
LogClient a
msg
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
B.hPut Handle
h (ByteString -> ByteString
addHeader (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
msg) 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 :: Int -> Session a -> Session a
withTimeout Int
duration Session a
f = do
  Chan SessionMessage
chan <- (SessionContext -> Chan SessionMessage)
-> Session (Chan SessionMessage)
forall r (m :: * -> *) b. HasReader r m => (r -> b) -> m b
asks SessionContext -> Chan SessionMessage
messageChan
  Int
timeoutId <- Session Int
forall (m :: * -> *).
(HasReader SessionContext m, MonadIO m) =>
m Int
getCurTimeoutId
  (SessionState -> SessionState) -> Session ()
forall s (m :: * -> *). HasState s m => (s -> s) -> m ()
modify ((SessionState -> SessionState) -> Session ())
-> (SessionState -> SessionState) -> Session ()
forall a b. (a -> b) -> a -> b
$ \SessionState
s -> SessionState
s { overridingTimeout :: Bool
overridingTimeout = Bool
True }
  ThreadId
tid <- IO ThreadId -> Session ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> Session ThreadId)
-> IO ThreadId -> Session ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    Int -> IO ()
threadDelay (Int
duration Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000)
    Chan SessionMessage -> SessionMessage -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan SessionMessage
chan (Int -> SessionMessage
TimeoutMessage Int
timeoutId)
  a
res <- Session a
f
  IO () -> Session ()
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 :: Bool
overridingTimeout = Bool
False }
  a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

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

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

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

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