{-# 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
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
data SessionConfig = SessionConfig
{ SessionConfig -> Int
messageTimeout :: Int
, SessionConfig -> Bool
logStdErr :: Bool
, SessionConfig -> Bool
logMessages :: Bool
, SessionConfig -> Bool
logColor :: Bool
, SessionConfig -> Maybe Value
lspConfig :: Maybe Value
, SessionConfig -> Bool
ignoreLogNotifications :: Bool
, SessionConfig -> Maybe [WorkspaceFolder]
initialWorkspaceFolders :: Maybe [WorkspaceFolder]
}
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
, SessionContext -> IORef Int
curTimeoutId :: IORef Int
, 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
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
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
, SessionState -> Maybe FromServerMessage
lastReceivedMessage :: !(Maybe FromServerMessage)
, SessionState -> Map Text SomeRegistration
curDynCaps :: !(Map.Map T.Text SomeRegistration)
, 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
runSession' :: Handle
-> Handle
-> Maybe ProcessHandle
-> (Handle -> SessionContext -> IO ())
-> SessionConfig
-> ClientCapabilities
-> FilePath
-> Session ()
-> 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
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
#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))
(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 ()
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 ()
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
[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
[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'
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
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)
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
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)
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
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))
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
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