{-# 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.Catch (MonadThrow)
import Control.Monad.Except
import Control.Monad.IO.Class
#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 (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 (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 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 =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM
  SessionMessage
  FromServerMessage
  (StateT SessionState (ReaderT SessionContext IO))
  ()
watchdog 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 forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM 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
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 = 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 (ResponseMessage '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 (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 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
SWindowWorkDoneProgressCreate Message m
req) =
      forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage forall a b. (a -> b) -> a -> b
$ forall (f :: From) (m :: Method f 'Request).
Text
-> Maybe (LspId m)
-> Either ResponseError (ResponseResult m)
-> ResponseMessage m
ResponseMessage Text
"2.0" (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Message m
req forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
LSP.id) (forall a b. b -> Either a b
Right Empty
Empty)
    respond (FromServerMess SMethod m
SWorkspaceApplyEdit Message 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 :: From) (m :: Method f 'Request).
Text
-> Maybe (LspId m)
-> Either ResponseError (ResponseResult m)
-> ResponseMessage m
ResponseMessage Text
"2.0" (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Message m
r forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
LSP.id) (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Text -> Maybe UInt -> ApplyWorkspaceEditResponseBody
ApplyWorkspaceEditResponseBody 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
textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
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
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
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
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
SProgress Message m
req) = case Message m
req forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasValue s a => Lens' s a
value of
  Begin WorkDoneProgressBeginParams
_ ->
    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 (Message m
req forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasToken s a => Lens' s a
token) forall a b. (a -> b) -> a -> b
$ SessionState -> Set ProgressToken
curProgressSessions SessionState
s }
  End WorkDoneProgressEndParams
_ ->
    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 (Message m
req forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasToken s a => Lens' s a
token) forall a b. (a -> b) -> a -> b
$ SessionState -> Set ProgressToken
curProgressSessions SessionState
s }
  SomeProgressParams
_ -> 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 forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
LSP.id, SomeRegistration
sr)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message m
req forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasRegistrations s a => Lens' s a
registrations
  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
SClientUnregisterCapability Message m
req) = do
  let List [Text]
unRegs = (forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
LSP.id) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Message m
req forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUnregisterations s a => Lens' s a
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
STextDocumentPublishDiagnostics Message m
n) = do
  let List [Diagnostic]
diags = Message m
n forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasDiagnostics s a => Lens' s a
diagnostics
      doc :: Uri
doc = Message m
n forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
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
SWorkspaceApplyEdit Message m
r) = do

  -- First, prefer the versioned documentChanges field
  [DidChangeTextDocumentParams]
allChangeParams <- case Message m
r forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasEdit s a => Lens' s a
edit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasDocumentChanges s a => Lens' s a
documentChanges of
    Just (List [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 a1 b a2. Prism (a1 |? b) (a2 |? b) a1 a2
_InL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTextDocument s a => Lens' s a
textDocument) 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 (List DocumentChange)
Nothing -> case Message m
r forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasEdit s a => Lens' s a
edit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasChanges s a => Lens' s a
changes of
      Just HashMap Uri (List TextEdit)
cs -> do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Uri -> m ()
checkIfNeedsOpened (forall k v. HashMap k v -> [k]
HashMap.keys HashMap Uri (List 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 {f :: * -> *}.
HasState SessionState f =>
Uri -> List TextEdit -> f [DidChangeTextDocumentParams]
getChangeParams) (forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Uri (List TextEdit)
cs)
      Maybe (HashMap Uri (List 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)
-> Message 'WorkspaceApplyEdit -> m ()
changeFromServerVFS LogAction (StateT VFS Identity) (WithSeverity VfsLog)
logger Message 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
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
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 :: 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 = 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
textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasVersion s a => Lens' s a
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
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 TextDocumentVersion
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
oldV Int
file_ver Rope
t) = Int32 -> Int -> Rope -> VirtualFile
VirtualFile (forall a. a -> Maybe a -> a
fromMaybe Int32
oldV TextDocumentVersion
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 :: NotificationMessage 'TextDocumentDidOpen
msg = 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)
            forall (m :: * -> *) a.
(MonadIO m, HasReader SessionContext m, ToJSON a) =>
a -> m ()
sendMessage NotificationMessage '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)
-> Message 'TextDocumentDidOpen -> m ()
openVFS LogAction (StateT VFS Identity) (WithSeverity VfsLog)
logger NotificationMessage '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 -> DidChangeTextDocumentParams
        getParamsFromTextDocumentEdit :: TextDocumentEdit -> DidChangeTextDocumentParams
getParamsFromTextDocumentEdit (TextDocumentEdit VersionedTextDocumentIdentifier
docId (List [TextEdit |? AnnotatedTextEdit]
edits)) = do
          VersionedTextDocumentIdentifier
-> List TextDocumentContentChangeEvent
-> DidChangeTextDocumentParams
DidChangeTextDocumentParams VersionedTextDocumentIdentifier
docId (forall a. [a] -> List a
List forall a b. (a -> b) -> a -> b
$ 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 (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ AnnotatedTextEdit
e forall s a. s -> Getting a s a -> a
^. forall s a. HasRange s a => Lens' s a
range) forall a. Maybe a
Nothing (AnnotatedTextEdit
e forall s a. s -> Getting a s a -> a
^. forall s a. HasNewText s a => Lens' s a
newText)
        editToChangeEvent (InL TextEdit
e) = Maybe Range -> Maybe UInt -> Text -> TextDocumentContentChangeEvent
TextDocumentContentChangeEvent (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TextEdit
e forall s a. s -> Getting a s a -> a
^. forall s a. HasRange s a => Lens' s a
range) forall a. Maybe a
Nothing (TextEdit
e forall s a. s -> Getting a s a -> a
^. forall s a. HasNewText s a => Lens' s a
newText)

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

        bumpNewestVersion :: VersionedTextDocumentIdentifier
-> f VersionedTextDocumentIdentifier
bumpNewestVersion (VersionedTextDocumentIdentifier Uri
uri TextDocumentVersion
_) =
          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 -> TextDocumentVersion -> VersionedTextDocumentIdentifier
VersionedTextDocumentIdentifier Uri
uri forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) [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) -> VersionedTextDocumentIdentifier
-> List (TextEdit |? AnnotatedTextEdit) -> TextDocumentEdit
TextDocumentEdit VersionedTextDocumentIdentifier
v (forall a. [a] -> List a
List [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 -> List TextEdit -> f [DidChangeTextDocumentParams]
getChangeParams Uri
uri (List [TextEdit]
edits) = do
          forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure TextDocumentEdit -> DidChangeTextDocumentParams
getParamsFromTextDocumentEdit forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {m :: * -> *}.
HasState SessionState m =>
Uri -> [TextEdit] -> m [TextDocumentEdit]
textDocumentEdits Uri
uri (forall a. [a] -> [a]
reverse [TextEdit]
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
contentChanges)) [DidChangeTextDocumentParams]
params))
                              in VersionedTextDocumentIdentifier
-> List 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
textDocument) (forall a. [a] -> List a
List [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