{-# LANGUAGE CPP               #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLabels #-}
{-# 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.Catch (MonadThrow)
import Control.Monad.Except
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
#if __GLASGOW_HASKELL__ == 806
import Control.Monad.Fail
#endif
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
import qualified Control.Monad.Trans.Reader as Reader (ask)
import Control.Monad.Trans.State (StateT, runStateT, execState)
import qualified Control.Monad.Trans.State as State
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Aeson hiding (Error, Null)
import Data.Aeson.Encode.Pretty
import Data.Conduit as Conduit
import Data.Conduit.Parser as Parser
import Data.Default
import Data.Foldable
import Data.List
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Maybe
import Data.Function
import Language.LSP.Protocol.Types as LSP
import qualified Language.LSP.Protocol.Lens as L
import Language.LSP.Protocol.Message as LSP
import Language.LSP.VFS
import Language.LSP.Test.Compat
import Language.LSP.Test.Decoding
import Language.LSP.Test.Exceptions
import System.Console.ANSI
import System.Directory
import System.IO
import System.Process (ProcessHandle())
#ifndef mingw32_HOST_OS
import System.Process (waitForProcess)
#endif
import System.Timeout ( timeout )
import Data.IORef
import Colog.Core (LogAction (..), WithSeverity (..), Severity (..))
import Data.Row

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

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

#if __GLASGOW_HASKELL__ >= 806
instance MonadFail Session where
  fail :: forall a. String -> Session a
fail String
s = do
    FromServerMessage
lastMsg <- forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionState -> Maybe FromServerMessage
lastReceivedMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). HasState s m => m s
get
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 forall a. Maybe a
Nothing Bool
False 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
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 (TResponseMessage 'Method_Initialize)
initRsp :: MVar (TResponseMessage Method_Initialize)
  , SessionContext -> SessionConfig
config :: SessionConfig
  , SessionContext -> ClientCapabilities
sessionCapabilities :: ClientCapabilities
  }

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

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

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

-- Pass this the timeoutid you *were* waiting on
bumpTimeoutId :: (HasReader SessionContext m, MonadIO m) => Int -> m ()
bumpTimeoutId :: forall (m :: * -> *).
(HasReader SessionContext m, MonadIO m) =>
Int -> m ()
bumpTimeoutId Int
prev = do
  IORef Int
v <- 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
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
v (\Int
x -> (forall a. Ord a => a -> a -> a
max Int
x (Int
prev 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 = forall s (m :: * -> *). HasState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall s (m :: * -> *). HasState s m => s -> m ()
put 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 = forall s (m :: * -> *). HasState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> m s
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall s (m :: * -> *). HasState s m => s -> m ()
put

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

runSessionMonad :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
runSessionMonad :: forall a.
SessionContext -> SessionState -> Session a -> IO (a, SessionState)
runSessionMonad SessionContext
context SessionState
state (Session ConduitParser
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  a
session) = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (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 = forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ ConduitT
  ()
  SessionMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
chanSource forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitM
  SessionMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
watchdog forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitM
  FromServerMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
updateStateC forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) i a.
MonadThrow m =>
ConduitParser i m a -> ConduitT i Void m a
runConduitParser (forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ConduitParser
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  a
session 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 <- forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionState -> Maybe FromServerMessage
lastReceivedMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). HasState s m => m s
get
      Text
name <- forall i (m :: * -> *). ConduitParser i m Text
getParserName
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a e. Exception e => e -> a
throw (String -> FromServerMessage -> SessionException
UnexpectedMessage (Text -> String
T.unpack Text
name) FromServerMessage
lastMsg)

    handler ConduitParserException
e = forall a e. Exception e => e -> a
throw ConduitParserException
e

    chanSource :: ConduitT
  ()
  SessionMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
chanSource = do
      SessionMessage
msg <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Chan a -> IO a
readChan (SessionContext -> Chan SessionMessage
messageChan SessionContext
context)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SessionConfig -> Bool
ignoreLogNotifications (SessionContext -> SessionConfig
config SessionContext
context) Bool -> Bool -> Bool
&& SessionMessage -> Bool
isLogNotification SessionMessage
msg) forall a b. (a -> b) -> a -> b
$
        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
SMethod_WindowShowMessage TMessage m
_)) = Bool
True
    isLogNotification (ServerMessage (FromServerMess SMethod m
SMethod_WindowLogMessage TMessage m
_)) = Bool
True
    isLogNotification (ServerMessage (FromServerMess SMethod m
SMethod_WindowShowDocument TMessage 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 = forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
Conduit.awaitForever forall a b. (a -> b) -> a -> b
$ \SessionMessage
msg -> do
      Int
curId <- forall (m :: * -> *).
(HasReader SessionContext m, MonadIO m) =>
m Int
getCurTimeoutId
      case SessionMessage
msg of
        ServerMessage FromServerMessage
sMsg -> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield FromServerMessage
sMsg
        TimeoutMessage Int
tId -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
curId forall a. Eq a => a -> a -> Bool
== Int
tId) forall a b. (a -> b) -> a -> b
$ SessionState -> Maybe FromServerMessage
lastReceivedMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). HasState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a e. Exception e => e -> a
throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FromServerMessage -> SessionException
Timeout

-- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
-- It also does not automatically send initialize and exit messages.
runSession' :: Handle -- ^ Server in
            -> Handle -- ^ Server out
            -> Maybe ProcessHandle -- ^ Server process
            -> (Handle -> SessionContext -> IO ()) -- ^ Server listener
            -> SessionConfig
            -> ClientCapabilities
            -> FilePath -- ^ Root directory
            -> Session () -- ^ To exit the Server properly
            -> Session a
            -> IO a
runSession' :: forall a.
Handle
-> Handle
-> Maybe ProcessHandle
-> (Handle -> SessionContext -> IO ())
-> SessionConfig
-> ClientCapabilities
-> String
-> Session ()
-> Session a
-> IO a
runSession' Handle
serverIn Handle
serverOut Maybe ProcessHandle
mServerProc Handle -> SessionContext -> IO ()
serverHandler SessionConfig
config ClientCapabilities
caps String
rootDir Session ()
exitServer Session a
session = do
  String
absRootDir <- String -> IO String
canonicalizePath String
rootDir

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

  MVar RequestMap
reqMap <- forall a. a -> IO (MVar a)
newMVar RequestMap
newRequestMap
  Chan SessionMessage
messageChan <- forall a. IO (Chan a)
newChan
  IORef Int
timeoutIdVar <- forall a. a -> IO (IORef a)
newIORef Int
0
  MVar (TResponseMessage 'Method_Initialize)
initRsp <- forall a. IO (MVar a)
newEmptyMVar

  ThreadId
mainThreadId <- IO ThreadId
myThreadId

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

      errorHandler :: SessionException -> IO ()
errorHandler = forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
mainThreadId :: SessionException -> IO ()
      serverListenerLauncher :: IO ThreadId
serverListenerLauncher =
        IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ 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 forall a. Num a => a -> a -> a
* Int
10forall 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
                  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 (forall a. a -> Maybe a
Just Handle
serverIn, forall a. a -> Maybe a
Just Handle
serverOut, forall a. Maybe a
Nothing, ProcessHandle
sp)
              | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        forall a b. IO a -> IO b -> IO a
finally (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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
cleanup)

  (a
result, SessionState
_) <- forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO ThreadId
serverListenerLauncher
                         ThreadId -> IO (Maybe ((), SessionState))
serverAndListenerFinalizer
                         (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall r. (VFS -> IO r) -> IO r
initVFS forall a b. (a -> b) -> a -> b
$ \VFS
vfs -> forall a.
SessionContext -> SessionState -> Session a -> IO (a, SessionState)
runSessionMonad SessionContext
context (VFS -> SessionState
initState VFS
vfs) Session a
session)
  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 = forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever forall a b. (a -> b) -> a -> b
$ \FromServerMessage
msg -> do
  forall (m :: * -> *).
(MonadIO m, HasReader SessionContext m, HasState SessionState m) =>
FromServerMessage -> m ()
updateState FromServerMessage
msg
  forall (m :: * -> *).
(MonadIO m, HasReader SessionContext m) =>
FromServerMessage -> m ()
respond FromServerMessage
msg
  forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield FromServerMessage
msg
  where
    respond :: (MonadIO m, HasReader SessionContext m) => FromServerMessage -> m ()
    respond :: forall (m :: * -> *).
(MonadIO m, HasReader SessionContext m) =>
FromServerMessage -> m ()
respond (FromServerMess SMethod m
SMethod_WindowWorkDoneProgressCreate TMessage m
req) =
      forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage forall a b. (a -> b) -> a -> b
$ forall (f :: MessageDirection) (m :: Method f 'Request).
Text
-> Maybe (LspId m)
-> Either ResponseError (MessageResult m)
-> TResponseMessage m
TResponseMessage Text
"2.0" (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TMessage m
req forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
L.id) (forall a b. b -> Either a b
Right Null
Null)
    respond (FromServerMess SMethod m
SMethod_WorkspaceApplyEdit TMessage m
r) = do
      forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage forall a b. (a -> b) -> a -> b
$ forall (f :: MessageDirection) (m :: Method f 'Request).
Text
-> Maybe (LspId m)
-> Either ResponseError (MessageResult m)
-> TResponseMessage m
TResponseMessage Text
"2.0" (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TMessage m
r forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
L.id) (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Text -> Maybe UInt -> ApplyWorkspaceEditResult
ApplyWorkspaceEditResult Bool
True forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
    respond FromServerMessage
_ = 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 forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri
documentChangeUri (InR (InL CreateFile
x)) = CreateFile
x forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
L.uri
documentChangeUri (InR (InR (InL RenameFile
x))) = RenameFile
x forall s a. s -> Getting a s a -> a
^. forall s a. HasOldUri s a => Lens' s a
L.oldUri
documentChangeUri (InR (InR (InR DeleteFile
x))) = DeleteFile
x forall s a. s -> Getting a s a -> a
^. forall s a. HasUri s a => Lens' s a
L.uri

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

-- Keep track of dynamic capability registration
updateState (FromServerMess SMethod m
SMethod_ClientRegisterCapability TMessage m
req) = do
  let
    regs :: [SomeRegistration]
    regs :: [SomeRegistration]
regs = TMessage m
req forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall s a. HasParams s a => Lens' s a
L.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasRegistrations s a => Lens' s a
L.registrations forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Registration -> Maybe SomeRegistration
toSomeRegistration forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just
  let newRegs :: [(Text, SomeRegistration)]
newRegs = (\sr :: SomeRegistration
sr@(SomeRegistration TRegistration m
r) -> (TRegistration m
r forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
L.id, SomeRegistration
sr)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SomeRegistration]
regs
  forall s (m :: * -> *). HasState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \SessionState
s ->
    SessionState
s { curDynCaps :: Map Text SomeRegistration
curDynCaps = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (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
SMethod_ClientUnregisterCapability TMessage m
req) = do
  let unRegs :: [Text]
unRegs = (forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
L.id) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMessage m
req forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
L.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUnregisterations s a => Lens' s a
L.unregisterations
  forall s (m :: * -> *). HasState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \SessionState
s ->
    let newCurDynCaps :: Map Text SomeRegistration
newCurDynCaps = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' 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
SMethod_TextDocumentPublishDiagnostics TMessage m
n) = do
  let diags :: [Diagnostic]
diags = TMessage m
n forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
L.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasDiagnostics s a => Lens' s a
L.diagnostics
      doc :: Uri
doc = TMessage m
n forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
L.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri
  forall s (m :: * -> *). HasState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \SessionState
s ->
    let newDiags :: Map NormalizedUri [Diagnostic]
newDiags = 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
SMethod_WorkspaceApplyEdit TMessage m
r) = do

  -- First, prefer the versioned documentChanges field
  [DidChangeTextDocumentParams]
allChangeParams <- case TMessage m
r forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
L.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasEdit s a => Lens' s a
L.edit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasDocumentChanges s a => Lens' s a
L.documentChanges of
    Just ([DocumentChange]
cs) -> do
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Uri -> m ()
checkIfNeedsOpened 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' <- forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
traverseOf (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism' (a |? b) a
_L forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism'
  OptionalVersionedTextDocumentIdentifier
  VersionedTextDocumentIdentifier
_versionedTextDocumentIdentifier) forall {f :: * -> *}.
HasState SessionState f =>
VersionedTextDocumentIdentifier
-> f VersionedTextDocumentIdentifier
bumpNewestVersion [DocumentChange]
cs
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DocumentChange -> Maybe DidChangeTextDocumentParams
getParamsFromDocumentChange [DocumentChange]
cs'
    -- Then fall back to the changes field
    Maybe [DocumentChange]
Nothing -> case TMessage m
r forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
L.params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasEdit s a => Lens' s a
L.edit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasChanges s a => Lens' s a
L.changes of
      Just Map Uri [TextEdit]
cs -> do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Uri -> m ()
checkIfNeedsOpened (forall k a. Map k a -> [k]
Map.keys Map Uri [TextEdit]
cs)
        forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall {m :: * -> *}.
HasState SessionState m =>
Uri -> [TextEdit] -> m [DidChangeTextDocumentParams]
getChangeParams) (forall k a. Map k a -> [(k, a)]
Map.toList Map Uri [TextEdit]
cs)
      Maybe (Map Uri [TextEdit])
Nothing ->
        forall a. HasCallStack => String -> a
error String
"WorkspaceEdit contains neither documentChanges nor changes!"

  forall s (m :: * -> *).
(HasState s m, HasState s m, Monad m) =>
(s -> m s) -> m ()
modifyM forall a b. (a -> b) -> a -> b
$ \SessionState
s -> do
    let newVFS :: VFS
newVFS = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> s
execState (SessionState -> VFS
vfs SessionState
s) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> TMessage 'Method_WorkspaceApplyEdit -> m ()
changeFromServerVFS LogAction (StateT VFS Identity) (WithSeverity VfsLog)
logger TMessage m
r
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SessionState
s { vfs :: VFS
vfs = VFS
newVFS }

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

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

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

  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [VersionedTextDocumentIdentifier]
latestVersions forall a b. (a -> b) -> a -> b
$ \(VersionedTextDocumentIdentifier Uri
uri Int32
v) ->
    forall s (m :: * -> *). HasState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \SessionState
s ->
      let oldVFS :: VFS
oldVFS = SessionState -> VFS
vfs SessionState
s
          update :: VirtualFile -> VirtualFile
update (VirtualFile Int32
_ Int
file_ver Rope
t) = Int32 -> Int -> Rope -> VirtualFile
VirtualFile Int32
v (Int
file_ver forall a. Num a => a -> a -> a
+Int
1) Rope
t
          newVFS :: VFS
newVFS = VFS
oldVFS forall a b. a -> (a -> b) -> b
& forall s a. HasVfsMap s a => Lens' s a
vfsMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (Uri -> NormalizedUri
toNormalizedUri Uri
uri) 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 = forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction forall a b. (a -> b) -> a -> b
$ \(WithSeverity VfsLog
msg Severity
sev) -> case Severity
sev of { Severity
Error -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show VfsLog
msg; Severity
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure () }
        checkIfNeedsOpened :: Uri -> m ()
checkIfNeedsOpened Uri
uri = do
          VFS
oldVFS <- SessionState -> VFS
vfs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). HasState s m => m s
get

          -- if its not open, open it
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall s a. Getting Any s a -> s -> Bool
has (forall s a. HasVfsMap s a => Lens' s a
vfsMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (Uri -> NormalizedUri
toNormalizedUri Uri
uri)) VFS
oldVFS) forall a b. (a -> b) -> a -> b
$ do
            let fp :: String
fp = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ Uri -> Maybe String
uriToFilePath Uri
uri
            Text
contents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Text
T.readFile String
fp
            let item :: TextDocumentItem
item = Uri -> Text -> Int32 -> Text -> TextDocumentItem
TextDocumentItem (String -> Uri
filePathToUri String
fp) Text
"" Int32
0 Text
contents
                msg :: TNotificationMessage 'Method_TextDocumentDidOpen
msg = forall (f :: MessageDirection) (m :: Method f 'Notification).
Text -> SMethod m -> MessageParams m -> TNotificationMessage m
TNotificationMessage Text
"2.0" SMethod 'Method_TextDocumentDidOpen
SMethod_TextDocumentDidOpen (TextDocumentItem -> DidOpenTextDocumentParams
DidOpenTextDocumentParams TextDocumentItem
item)
            forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage TNotificationMessage 'Method_TextDocumentDidOpen
msg

            forall s (m :: * -> *).
(HasState s m, HasState s m, Monad m) =>
(s -> m s) -> m ()
modifyM forall a b. (a -> b) -> a -> b
$ \SessionState
s -> do
              let newVFS :: VFS
newVFS = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> s
execState (SessionState -> VFS
vfs SessionState
s) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadState VFS m =>
LogAction m (WithSeverity VfsLog)
-> TMessage 'Method_TextDocumentDidOpen -> m ()
openVFS LogAction (StateT VFS Identity) (WithSeverity VfsLog)
logger TNotificationMessage 'Method_TextDocumentDidOpen
msg
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SessionState
s { vfs :: VFS
vfs = VFS
newVFS }

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

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

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

        bumpNewestVersion :: VersionedTextDocumentIdentifier
-> f VersionedTextDocumentIdentifier
bumpNewestVersion (VersionedTextDocumentIdentifier Uri
uri Int32
_) =
          forall a. [a] -> a
head forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). HasState s m => m s
get
          let curVer :: Int32
curVer = forall a. a -> Maybe a -> a
fromMaybe Int32
0 forall a b. (a -> b) -> a -> b
$ VFS
vfs forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasVfsMap s a => Lens' s a
vfsMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (Uri -> NormalizedUri
toNormalizedUri Uri
uri) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasLsp_version s a => Lens' s a
lsp_version
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Uri -> Int32 -> VersionedTextDocumentIdentifier
VersionedTextDocumentIdentifier Uri
uri) [Int32
curVer forall a. Num a => a -> a -> a
+ Int32
1..]

        textDocumentEdits :: Uri -> [TextEdit] -> m [TextDocumentEdit]
textDocumentEdits Uri
uri [TextEdit]
edits = do
          [VersionedTextDocumentIdentifier]
vers <- forall {m :: * -> *}.
HasState SessionState m =>
Uri -> m [VersionedTextDocumentIdentifier]
textDocumentVersions Uri
uri
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(VersionedTextDocumentIdentifier
v, TextEdit
e) -> OptionalVersionedTextDocumentIdentifier
-> [TextEdit |? AnnotatedTextEdit] -> TextDocumentEdit
TextDocumentEdit (forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review Prism'
  OptionalVersionedTextDocumentIdentifier
  VersionedTextDocumentIdentifier
_versionedTextDocumentIdentifier VersionedTextDocumentIdentifier
v) [forall a b. a -> a |? b
InL TextEdit
e]) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [VersionedTextDocumentIdentifier]
vers [TextEdit]
edits

        getChangeParams :: Uri -> [TextEdit] -> m [DidChangeTextDocumentParams]
getChangeParams Uri
uri [TextEdit]
edits = do
          [TextDocumentEdit]
edits <- forall {m :: * -> *}.
HasState SessionState m =>
Uri -> [TextEdit] -> m [TextDocumentEdit]
textDocumentEdits Uri
uri (forall a. [a] -> [a]
reverse [TextEdit]
edits)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map TextDocumentEdit -> Maybe DidChangeTextDocumentParams
getParamsFromTextDocumentEdit [TextDocumentEdit]
edits

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

sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()
sendMessage :: forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage a
msg = do
  Handle
h <- SessionContext -> Handle
serverIn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). HasReader r m => m r
ask
  forall a (m :: * -> *).
(ToJSON a, MonadIO m, HasReader SessionContext m) =>
LogMsgType -> a -> m ()
logMsg LogMsgType
LogClient a
msg
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
B.hPut Handle
h (ByteString -> ByteString
addHeader forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode a
msg) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (forall a e. Exception e => e -> a
throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> IOError -> SessionException
MessageSendError (forall a. ToJSON a => a -> Value
toJSON a
msg))

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

data LogMsgType = LogServer | LogClient
  deriving LogMsgType -> LogMsgType -> Bool
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 :: forall a (m :: * -> *).
(ToJSON a, MonadIO m, HasReader SessionContext m) =>
LogMsgType -> a -> m ()
logMsg LogMsgType
t a
msg = do
  Bool
shouldLog <- forall r (m :: * -> *) b. HasReader r m => (r -> b) -> m b
asks forall a b. (a -> b) -> a -> b
$ SessionConfig -> Bool
logMessages forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionContext -> SessionConfig
config
  Bool
shouldColor <- forall r (m :: * -> *) b. HasReader r m => (r -> b) -> m b
asks forall a b. (a -> b) -> a -> b
$ SessionConfig -> Bool
logColor forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionContext -> SessionConfig
config
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldLog forall a b. (a -> b) -> a -> b
$ do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldColor forall a b. (a -> b) -> a -> b
$ [SGR] -> IO ()
setSGR [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
color]
    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
arrow forall a. [a] -> [a] -> [a]
++ a -> String
showPretty a
msg
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldColor forall a b. (a -> b) -> a -> b
$ [SGR] -> IO ()
setSGR [SGR
Reset]

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

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