{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CUSKs #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
{-# OPTIONS_GHC -fprint-explicit-kinds #-}
module Language.LSP.Server.Core where
import Colog.Core (
LogAction (..),
Severity (..),
WithSeverity (..),
(<&),
)
import Control.Concurrent.Extra as C
import Control.Concurrent.STM
import Control.Lens (at, (^.), (^?), _Just)
import Control.Monad
import Control.Monad.Catch (
MonadCatch,
MonadMask,
MonadThrow,
)
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Control.Monad.Trans.Class
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Reader
import Data.Aeson qualified as J
import Data.Default
import Data.Functor.Product
import Data.HashMap.Strict qualified as HM
import Data.IxMap
import Data.Kind
import Data.List qualified as L
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Monoid (Ap (..))
import Data.Ord (Down (Down))
import Data.Text (Text)
import Data.Text qualified as T
import Language.LSP.Diagnostics
import Language.LSP.Protocol.Capabilities
import Language.LSP.Protocol.Lens qualified as L
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Message qualified as L
import Language.LSP.Protocol.Types
import Language.LSP.Protocol.Types qualified as L
import Language.LSP.Protocol.Utils.Misc (prettyJSON)
import Language.LSP.Protocol.Utils.SMethodMap (SMethodMap)
import Language.LSP.Protocol.Utils.SMethodMap qualified as SMethodMap
import Language.LSP.VFS hiding (end)
import Prettyprinter
{-# ANN module ("HLint: ignore Eta reduce" :: String) #-}
{-# ANN module ("HLint: ignore Redundant do" :: String) #-}
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
data LspCoreLog
=
NewConfig J.Value
| ConfigurationParseError J.Value T.Text
| ConfigurationNotSupported
| BadConfigurationResponse (TResponseError Method_WorkspaceConfiguration)
| WrongConfigSections [J.Value]
| forall m. CantRegister (SMethod m)
deriving instance (Show LspCoreLog)
instance Pretty LspCoreLog where
pretty :: forall ann. LspCoreLog -> Doc ann
pretty (NewConfig Value
config) = Doc ann
"LSP: set new config:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value -> Doc ann
forall ann. Value -> Doc ann
prettyJSON Value
config
pretty LspCoreLog
ConfigurationNotSupported = Doc ann
"LSP: not requesting configuration since the client does not support workspace/configuration"
pretty (ConfigurationParseError Value
settings Text
err) =
[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
[ Doc ann
"LSP: configuration parse error:"
, Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
err
, Doc ann
"when parsing"
, Value -> Doc ann
forall ann. Value -> Doc ann
prettyJSON Value
settings
]
pretty (BadConfigurationResponse TResponseError @'ServerToClient 'Method_WorkspaceConfiguration
err) = Doc ann
"LSP: error when requesting configuration: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TResponseError @'ServerToClient 'Method_WorkspaceConfiguration
-> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann.
TResponseError @'ServerToClient 'Method_WorkspaceConfiguration
-> Doc ann
pretty TResponseError @'ServerToClient 'Method_WorkspaceConfiguration
err
pretty (WrongConfigSections [Value]
sections) = Doc ann
"LSP: expected only one configuration section, got: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value -> Doc ann
forall ann. Value -> Doc ann
prettyJSON ([Value] -> Value
forall a. ToJSON a => a -> Value
J.toJSON [Value]
sections)
pretty (CantRegister SMethod @f @t m
m) = Doc ann
"LSP: can't register dynamically for:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> SMethod @f @t m -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. SMethod @f @t m -> Doc ann
pretty SMethod @f @t m
m
newtype LspT config m a = LspT {forall config (m :: * -> *) a.
LspT config m a -> ReaderT (LanguageContextEnv config) m a
unLspT :: ReaderT (LanguageContextEnv config) m a}
deriving ((forall a b. (a -> b) -> LspT config m a -> LspT config m b)
-> (forall a b. a -> LspT config m b -> LspT config m a)
-> Functor (LspT config m)
forall a b. a -> LspT config m b -> LspT config m a
forall a b. (a -> b) -> LspT config m a -> LspT config m b
forall config (m :: * -> *) a b.
Functor m =>
a -> LspT config m b -> LspT config m a
forall config (m :: * -> *) a b.
Functor m =>
(a -> b) -> LspT config m a -> LspT config m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall config (m :: * -> *) a b.
Functor m =>
(a -> b) -> LspT config m a -> LspT config m b
fmap :: forall a b. (a -> b) -> LspT config m a -> LspT config m b
$c<$ :: forall config (m :: * -> *) a b.
Functor m =>
a -> LspT config m b -> LspT config m a
<$ :: forall a b. a -> LspT config m b -> LspT config m a
Functor, Functor (LspT config m)
Functor (LspT config m) =>
(forall a. a -> LspT config m a)
-> (forall a b.
LspT config m (a -> b) -> LspT config m a -> LspT config m b)
-> (forall a b c.
(a -> b -> c)
-> LspT config m a -> LspT config m b -> LspT config m c)
-> (forall a b.
LspT config m a -> LspT config m b -> LspT config m b)
-> (forall a b.
LspT config m a -> LspT config m b -> LspT config m a)
-> Applicative (LspT config m)
forall a. a -> LspT config m a
forall a b. LspT config m a -> LspT config m b -> LspT config m a
forall a b. LspT config m a -> LspT config m b -> LspT config m b
forall a b.
LspT config m (a -> b) -> LspT config m a -> LspT config m b
forall a b c.
(a -> b -> c)
-> LspT config m a -> LspT config m b -> LspT config m c
forall config (m :: * -> *).
Applicative m =>
Functor (LspT config m)
forall config (m :: * -> *) a.
Applicative m =>
a -> LspT config m a
forall config (m :: * -> *) a b.
Applicative m =>
LspT config m a -> LspT config m b -> LspT config m a
forall config (m :: * -> *) a b.
Applicative m =>
LspT config m a -> LspT config m b -> LspT config m b
forall config (m :: * -> *) a b.
Applicative m =>
LspT config m (a -> b) -> LspT config m a -> LspT config m b
forall config (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> LspT config m a -> LspT config m b -> LspT config m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall config (m :: * -> *) a.
Applicative m =>
a -> LspT config m a
pure :: forall a. a -> LspT config m a
$c<*> :: forall config (m :: * -> *) a b.
Applicative m =>
LspT config m (a -> b) -> LspT config m a -> LspT config m b
<*> :: forall a b.
LspT config m (a -> b) -> LspT config m a -> LspT config m b
$cliftA2 :: forall config (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> LspT config m a -> LspT config m b -> LspT config m c
liftA2 :: forall a b c.
(a -> b -> c)
-> LspT config m a -> LspT config m b -> LspT config m c
$c*> :: forall config (m :: * -> *) a b.
Applicative m =>
LspT config m a -> LspT config m b -> LspT config m b
*> :: forall a b. LspT config m a -> LspT config m b -> LspT config m b
$c<* :: forall config (m :: * -> *) a b.
Applicative m =>
LspT config m a -> LspT config m b -> LspT config m a
<* :: forall a b. LspT config m a -> LspT config m b -> LspT config m a
Applicative, Applicative (LspT config m)
Applicative (LspT config m) =>
(forall a b.
LspT config m a -> (a -> LspT config m b) -> LspT config m b)
-> (forall a b.
LspT config m a -> LspT config m b -> LspT config m b)
-> (forall a. a -> LspT config m a)
-> Monad (LspT config m)
forall a. a -> LspT config m a
forall a b. LspT config m a -> LspT config m b -> LspT config m b
forall a b.
LspT config m a -> (a -> LspT config m b) -> LspT config m b
forall config (m :: * -> *). Monad m => Applicative (LspT config m)
forall config (m :: * -> *) a. Monad m => a -> LspT config m a
forall config (m :: * -> *) a b.
Monad m =>
LspT config m a -> LspT config m b -> LspT config m b
forall config (m :: * -> *) a b.
Monad m =>
LspT config m a -> (a -> LspT config m b) -> LspT config m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall config (m :: * -> *) a b.
Monad m =>
LspT config m a -> (a -> LspT config m b) -> LspT config m b
>>= :: forall a b.
LspT config m a -> (a -> LspT config m b) -> LspT config m b
$c>> :: forall config (m :: * -> *) a b.
Monad m =>
LspT config m a -> LspT config m b -> LspT config m b
>> :: forall a b. LspT config m a -> LspT config m b -> LspT config m b
$creturn :: forall config (m :: * -> *) a. Monad m => a -> LspT config m a
return :: forall a. a -> LspT config m a
Monad, MonadThrow (LspT config m)
MonadThrow (LspT config m) =>
(forall e a.
(HasCallStack, Exception e) =>
LspT config m a -> (e -> LspT config m a) -> LspT config m a)
-> MonadCatch (LspT config m)
forall e a.
(HasCallStack, Exception e) =>
LspT config m a -> (e -> LspT config m a) -> LspT config m a
forall config (m :: * -> *).
MonadCatch m =>
MonadThrow (LspT config m)
forall config (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
LspT config m a -> (e -> LspT config m a) -> LspT config m a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
(HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall config (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
LspT config m a -> (e -> LspT config m a) -> LspT config m a
catch :: forall e a.
(HasCallStack, Exception e) =>
LspT config m a -> (e -> LspT config m a) -> LspT config m a
MonadCatch, Monad (LspT config m)
Monad (LspT config m) =>
(forall a. IO a -> LspT config m a) -> MonadIO (LspT config m)
forall a. IO a -> LspT config m a
forall config (m :: * -> *). MonadIO m => Monad (LspT config m)
forall config (m :: * -> *) a. MonadIO m => IO a -> LspT config m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall config (m :: * -> *) a. MonadIO m => IO a -> LspT config m a
liftIO :: forall a. IO a -> LspT config m a
MonadIO, MonadCatch (LspT config m)
MonadCatch (LspT config m) =>
(forall b.
HasCallStack =>
((forall a. LspT config m a -> LspT config m a) -> LspT config m b)
-> LspT config m b)
-> (forall b.
HasCallStack =>
((forall a. LspT config m a -> LspT config m a) -> LspT config m b)
-> LspT config m b)
-> (forall a b c.
HasCallStack =>
LspT config m a
-> (a -> ExitCase b -> LspT config m c)
-> (a -> LspT config m b)
-> LspT config m (b, c))
-> MonadMask (LspT config m)
forall b.
HasCallStack =>
((forall a. LspT config m a -> LspT config m a) -> LspT config m b)
-> LspT config m b
forall a b c.
HasCallStack =>
LspT config m a
-> (a -> ExitCase b -> LspT config m c)
-> (a -> LspT config m b)
-> LspT config m (b, c)
forall config (m :: * -> *).
MonadMask m =>
MonadCatch (LspT config m)
forall config (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. LspT config m a -> LspT config m a) -> LspT config m b)
-> LspT config m b
forall config (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
LspT config m a
-> (a -> ExitCase b -> LspT config m c)
-> (a -> LspT config m b)
-> LspT config m (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
HasCallStack =>
((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
HasCallStack =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall config (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. LspT config m a -> LspT config m a) -> LspT config m b)
-> LspT config m b
mask :: forall b.
HasCallStack =>
((forall a. LspT config m a -> LspT config m a) -> LspT config m b)
-> LspT config m b
$cuninterruptibleMask :: forall config (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. LspT config m a -> LspT config m a) -> LspT config m b)
-> LspT config m b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. LspT config m a -> LspT config m a) -> LspT config m b)
-> LspT config m b
$cgeneralBracket :: forall config (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
LspT config m a
-> (a -> ExitCase b -> LspT config m c)
-> (a -> LspT config m b)
-> LspT config m (b, c)
generalBracket :: forall a b c.
HasCallStack =>
LspT config m a
-> (a -> ExitCase b -> LspT config m c)
-> (a -> LspT config m b)
-> LspT config m (b, c)
MonadMask, Monad (LspT config m)
Monad (LspT config m) =>
(forall e a. (HasCallStack, Exception e) => e -> LspT config m a)
-> MonadThrow (LspT config m)
forall e a. (HasCallStack, Exception e) => e -> LspT config m a
forall config (m :: * -> *). MonadThrow m => Monad (LspT config m)
forall config (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> LspT config m a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall config (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> LspT config m a
throwM :: forall e a. (HasCallStack, Exception e) => e -> LspT config m a
MonadThrow, (forall (m :: * -> *). Monad m => Monad (LspT config m)) =>
(forall (m :: * -> *) a. Monad m => m a -> LspT config m a)
-> MonadTrans (LspT config)
forall config (m :: * -> *). Monad m => Monad (LspT config m)
forall config (m :: * -> *) a. Monad m => m a -> LspT config m a
forall (m :: * -> *). Monad m => Monad (LspT config m)
forall (m :: * -> *) a. Monad m => m a -> LspT config m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall config (m :: * -> *) a. Monad m => m a -> LspT config m a
lift :: forall (m :: * -> *) a. Monad m => m a -> LspT config m a
MonadTrans, MonadIO (LspT config m)
MonadIO (LspT config m) =>
(forall b.
((forall a. LspT config m a -> IO a) -> IO b) -> LspT config m b)
-> MonadUnliftIO (LspT config m)
forall b.
((forall a. LspT config m a -> IO a) -> IO b) -> LspT config m b
forall config (m :: * -> *).
MonadUnliftIO m =>
MonadIO (LspT config m)
forall config (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. LspT config m a -> IO a) -> IO b) -> LspT config m b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
$cwithRunInIO :: forall config (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. LspT config m a -> IO a) -> IO b) -> LspT config m b
withRunInIO :: forall b.
((forall a. LspT config m a -> IO a) -> IO b) -> LspT config m b
MonadUnliftIO, Monad (LspT config m)
Monad (LspT config m) =>
(forall a. (a -> LspT config m a) -> LspT config m a)
-> MonadFix (LspT config m)
forall a. (a -> LspT config m a) -> LspT config m a
forall config (m :: * -> *). MonadFix m => Monad (LspT config m)
forall config (m :: * -> *) a.
MonadFix m =>
(a -> LspT config m a) -> LspT config m a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
$cmfix :: forall config (m :: * -> *) a.
MonadFix m =>
(a -> LspT config m a) -> LspT config m a
mfix :: forall a. (a -> LspT config m a) -> LspT config m a
MonadFix)
deriving (NonEmpty (LspT config m a) -> LspT config m a
LspT config m a -> LspT config m a -> LspT config m a
(LspT config m a -> LspT config m a -> LspT config m a)
-> (NonEmpty (LspT config m a) -> LspT config m a)
-> (forall b.
Integral b =>
b -> LspT config m a -> LspT config m a)
-> Semigroup (LspT config m a)
forall b. Integral b => b -> LspT config m a -> LspT config m a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall config (m :: * -> *) a.
(Applicative m, Semigroup a) =>
NonEmpty (LspT config m a) -> LspT config m a
forall config (m :: * -> *) a.
(Applicative m, Semigroup a) =>
LspT config m a -> LspT config m a -> LspT config m a
forall config (m :: * -> *) a b.
(Applicative m, Semigroup a, Integral b) =>
b -> LspT config m a -> LspT config m a
$c<> :: forall config (m :: * -> *) a.
(Applicative m, Semigroup a) =>
LspT config m a -> LspT config m a -> LspT config m a
<> :: LspT config m a -> LspT config m a -> LspT config m a
$csconcat :: forall config (m :: * -> *) a.
(Applicative m, Semigroup a) =>
NonEmpty (LspT config m a) -> LspT config m a
sconcat :: NonEmpty (LspT config m a) -> LspT config m a
$cstimes :: forall config (m :: * -> *) a b.
(Applicative m, Semigroup a, Integral b) =>
b -> LspT config m a -> LspT config m a
stimes :: forall b. Integral b => b -> LspT config m a -> LspT config m a
Semigroup, Semigroup (LspT config m a)
LspT config m a
Semigroup (LspT config m a) =>
LspT config m a
-> (LspT config m a -> LspT config m a -> LspT config m a)
-> ([LspT config m a] -> LspT config m a)
-> Monoid (LspT config m a)
[LspT config m a] -> LspT config m a
LspT config m a -> LspT config m a -> LspT config m a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall config (m :: * -> *) a.
(Applicative m, Monoid a) =>
Semigroup (LspT config m a)
forall config (m :: * -> *) a.
(Applicative m, Monoid a) =>
LspT config m a
forall config (m :: * -> *) a.
(Applicative m, Monoid a) =>
[LspT config m a] -> LspT config m a
forall config (m :: * -> *) a.
(Applicative m, Monoid a) =>
LspT config m a -> LspT config m a -> LspT config m a
$cmempty :: forall config (m :: * -> *) a.
(Applicative m, Monoid a) =>
LspT config m a
mempty :: LspT config m a
$cmappend :: forall config (m :: * -> *) a.
(Applicative m, Monoid a) =>
LspT config m a -> LspT config m a -> LspT config m a
mappend :: LspT config m a -> LspT config m a -> LspT config m a
$cmconcat :: forall config (m :: * -> *) a.
(Applicative m, Monoid a) =>
[LspT config m a] -> LspT config m a
mconcat :: [LspT config m a] -> LspT config m a
Monoid) via (Ap (LspT config m) a)
type role LspT representational representational nominal
runLspT :: LanguageContextEnv config -> LspT config m a -> m a
runLspT :: forall config (m :: * -> *) a.
LanguageContextEnv config -> LspT config m a -> m a
runLspT LanguageContextEnv config
env = (ReaderT (LanguageContextEnv config) m a
-> LanguageContextEnv config -> m a)
-> LanguageContextEnv config
-> ReaderT (LanguageContextEnv config) m a
-> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (LanguageContextEnv config) m a
-> LanguageContextEnv config -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT LanguageContextEnv config
env (ReaderT (LanguageContextEnv config) m a -> m a)
-> (LspT config m a -> ReaderT (LanguageContextEnv config) m a)
-> LspT config m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LspT config m a -> ReaderT (LanguageContextEnv config) m a
forall config (m :: * -> *) a.
LspT config m a -> ReaderT (LanguageContextEnv config) m a
unLspT
{-# INLINE runLspT #-}
type LspM config = LspT config IO
class MonadUnliftIO m => MonadLsp config m | m -> config where
getLspEnv :: m (LanguageContextEnv config)
instance MonadUnliftIO m => MonadLsp config (LspT config m) where
{-# SPECIALIZE instance MonadLsp config (LspT config IO) #-}
{-# INLINE getLspEnv #-}
getLspEnv :: LspT config m (LanguageContextEnv config)
getLspEnv = ReaderT (LanguageContextEnv config) m (LanguageContextEnv config)
-> LspT config m (LanguageContextEnv config)
forall config (m :: * -> *) a.
ReaderT (LanguageContextEnv config) m a -> LspT config m a
LspT ReaderT (LanguageContextEnv config) m (LanguageContextEnv config)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
instance MonadLsp c m => MonadLsp c (ReaderT r m) where
{-# SPECIALIZE instance MonadLsp config (ReaderT r (LspT config IO)) #-}
{-# INLINE getLspEnv #-}
getLspEnv :: ReaderT r m (LanguageContextEnv c)
getLspEnv = m (LanguageContextEnv c) -> ReaderT r m (LanguageContextEnv c)
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (LanguageContextEnv c)
forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
getLspEnv
instance MonadLsp c m => MonadLsp c (IdentityT m) where
getLspEnv :: IdentityT @(*) m (LanguageContextEnv c)
getLspEnv = m (LanguageContextEnv c) -> IdentityT @(*) m (LanguageContextEnv c)
forall (m :: * -> *) a. Monad m => m a -> IdentityT @(*) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (LanguageContextEnv c)
forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
getLspEnv
data LanguageContextEnv config = LanguageContextEnv
{ forall config. LanguageContextEnv config -> Handlers IO
resHandlers :: !(Handlers IO)
, forall config. LanguageContextEnv config -> Text
resConfigSection :: T.Text
, forall config.
LanguageContextEnv config -> config -> Value -> Either Text config
resParseConfig :: !(config -> J.Value -> Either T.Text config)
, forall config. LanguageContextEnv config -> config -> IO ()
resOnConfigChange :: !(config -> IO ())
, forall config.
LanguageContextEnv config -> FromServerMessage -> IO ()
resSendMessage :: !(FromServerMessage -> IO ())
,
forall config.
LanguageContextEnv config -> LanguageContextState config
resState :: !(LanguageContextState config)
, forall config. LanguageContextEnv config -> ClientCapabilities
resClientCapabilities :: !L.ClientCapabilities
, forall config. LanguageContextEnv config -> Maybe String
resRootPath :: !(Maybe FilePath)
, forall config. LanguageContextEnv config -> Int
resProgressStartDelay :: Int
, forall config. LanguageContextEnv config -> Int
resProgressUpdateDelay :: Int
}
data Handlers m = Handlers
{ forall (m :: * -> *).
Handlers m
-> SMethodMap
@'ClientToServer @'Request (ClientMessageHandler m 'Request)
reqHandlers :: !(SMethodMap (ClientMessageHandler m Request))
, forall (m :: * -> *).
Handlers m
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler m 'Notification)
notHandlers :: !(SMethodMap (ClientMessageHandler m Notification))
}
instance Semigroup (Handlers config) where
Handlers SMethodMap
@'ClientToServer @'Request (ClientMessageHandler config 'Request)
r1 SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler config 'Notification)
n1 <> :: Handlers config -> Handlers config -> Handlers config
<> Handlers SMethodMap
@'ClientToServer @'Request (ClientMessageHandler config 'Request)
r2 SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler config 'Notification)
n2 = SMethodMap
@'ClientToServer @'Request (ClientMessageHandler config 'Request)
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler config 'Notification)
-> Handlers config
forall (m :: * -> *).
SMethodMap
@'ClientToServer @'Request (ClientMessageHandler m 'Request)
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler m 'Notification)
-> Handlers m
Handlers (SMethodMap
@'ClientToServer @'Request (ClientMessageHandler config 'Request)
r1 SMethodMap
@'ClientToServer @'Request (ClientMessageHandler config 'Request)
-> SMethodMap
@'ClientToServer @'Request (ClientMessageHandler config 'Request)
-> SMethodMap
@'ClientToServer @'Request (ClientMessageHandler config 'Request)
forall a. Semigroup a => a -> a -> a
<> SMethodMap
@'ClientToServer @'Request (ClientMessageHandler config 'Request)
r2) (SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler config 'Notification)
n1 SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler config 'Notification)
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler config 'Notification)
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler config 'Notification)
forall a. Semigroup a => a -> a -> a
<> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler config 'Notification)
n2)
instance Monoid (Handlers config) where
mempty :: Handlers config
mempty = SMethodMap
@'ClientToServer @'Request (ClientMessageHandler config 'Request)
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler config 'Notification)
-> Handlers config
forall (m :: * -> *).
SMethodMap
@'ClientToServer @'Request (ClientMessageHandler m 'Request)
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler m 'Notification)
-> Handlers m
Handlers SMethodMap
@'ClientToServer @'Request (ClientMessageHandler config 'Request)
forall a. Monoid a => a
mempty SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler config 'Notification)
forall a. Monoid a => a
mempty
notificationHandler :: forall (m :: Method ClientToServer Notification) f. SMethod m -> Handler f m -> Handlers f
notificationHandler :: forall (m :: Method 'ClientToServer 'Notification) (f :: * -> *).
SMethod @'ClientToServer @'Notification m
-> Handler @'ClientToServer @'Notification f m -> Handlers f
notificationHandler SMethod @'ClientToServer @'Notification m
m Handler @'ClientToServer @'Notification f m
h = SMethodMap
@'ClientToServer @'Request (ClientMessageHandler f 'Request)
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler f 'Notification)
-> Handlers f
forall (m :: * -> *).
SMethodMap
@'ClientToServer @'Request (ClientMessageHandler m 'Request)
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler m 'Notification)
-> Handlers m
Handlers SMethodMap
@'ClientToServer @'Request (ClientMessageHandler f 'Request)
forall a. Monoid a => a
mempty (SMethod @'ClientToServer @'Notification m
-> ClientMessageHandler f 'Notification m
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler f 'Notification)
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
(v :: Method f t -> *).
SMethod @f @t a -> v a -> SMethodMap @f @t v
SMethodMap.singleton SMethod @'ClientToServer @'Notification m
m (Handler @'ClientToServer @'Notification f m
-> ClientMessageHandler f 'Notification m
forall (f :: * -> *) (t :: MessageKind)
(m :: Method 'ClientToServer t).
Handler @'ClientToServer @t f m -> ClientMessageHandler f t m
ClientMessageHandler Handler @'ClientToServer @'Notification f m
h))
requestHandler :: forall (m :: Method ClientToServer Request) f. SMethod m -> Handler f m -> Handlers f
requestHandler :: forall (m :: Method 'ClientToServer 'Request) (f :: * -> *).
SMethod @'ClientToServer @'Request m
-> Handler @'ClientToServer @'Request f m -> Handlers f
requestHandler SMethod @'ClientToServer @'Request m
m Handler @'ClientToServer @'Request f m
h = SMethodMap
@'ClientToServer @'Request (ClientMessageHandler f 'Request)
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler f 'Notification)
-> Handlers f
forall (m :: * -> *).
SMethodMap
@'ClientToServer @'Request (ClientMessageHandler m 'Request)
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler m 'Notification)
-> Handlers m
Handlers (SMethod @'ClientToServer @'Request m
-> ClientMessageHandler f 'Request m
-> SMethodMap
@'ClientToServer @'Request (ClientMessageHandler f 'Request)
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
(v :: Method f t -> *).
SMethod @f @t a -> v a -> SMethodMap @f @t v
SMethodMap.singleton SMethod @'ClientToServer @'Request m
m (Handler @'ClientToServer @'Request f m
-> ClientMessageHandler f 'Request m
forall (f :: * -> *) (t :: MessageKind)
(m :: Method 'ClientToServer t).
Handler @'ClientToServer @t f m -> ClientMessageHandler f t m
ClientMessageHandler Handler @'ClientToServer @'Request f m
h)) SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler f 'Notification)
forall a. Monoid a => a
mempty
newtype ClientMessageHandler f (t :: MessageKind) (m :: Method ClientToServer t) = ClientMessageHandler (Handler f m)
type family Handler (f :: Type -> Type) (m :: Method from t) = (result :: Type) | result -> f t m where
Handler f (m :: Method _from Request) = TRequestMessage m -> (Either (TResponseError m) (MessageResult m) -> f ()) -> f ()
Handler f (m :: Method _from Notification) = TNotificationMessage m -> f ()
data m <~> n = Iso
{ forall {k} (m :: k -> *) (n :: k -> *).
(<~>) @k m n -> forall (a :: k). m a -> n a
forward :: forall a. m a -> n a
, forall {k} (m :: k -> *) (n :: k -> *).
(<~>) @k m n -> forall (a :: k). n a -> m a
backward :: forall a. n a -> m a
}
transmuteHandlers :: (m <~> n) -> Handlers m -> Handlers n
transmuteHandlers :: forall (m :: * -> *) (n :: * -> *).
(<~>) @(*) m n -> Handlers m -> Handlers n
transmuteHandlers (<~>) @(*) m n
nat = (forall (a :: Method 'ClientToServer 'Request).
Handler @'ClientToServer @'Request m a
-> Handler @'ClientToServer @'Request n a)
-> (forall (a :: Method 'ClientToServer 'Notification).
Handler @'ClientToServer @'Notification m a
-> Handler @'ClientToServer @'Notification n a)
-> Handlers m
-> Handlers n
forall (m :: * -> *) (n :: * -> *).
(forall (a :: Method 'ClientToServer 'Request).
Handler @'ClientToServer @'Request m a
-> Handler @'ClientToServer @'Request n a)
-> (forall (a :: Method 'ClientToServer 'Notification).
Handler @'ClientToServer @'Notification m a
-> Handler @'ClientToServer @'Notification n a)
-> Handlers m
-> Handlers n
mapHandlers (\Handler @'ClientToServer @'Request m a
i TRequestMessage @'ClientToServer a
m Either
(TResponseError @'ClientToServer a)
(MessageResult @'ClientToServer @'Request a)
-> n ()
k -> (<~>) @(*) m n -> forall a. m a -> n a
forall {k} (m :: k -> *) (n :: k -> *).
(<~>) @k m n -> forall (a :: k). m a -> n a
forward (<~>) @(*) m n
nat (Handler @'ClientToServer @'Request m a
TRequestMessage @'ClientToServer a
-> (Either
(TResponseError @'ClientToServer a)
(MessageResult @'ClientToServer @'Request a)
-> m ())
-> m ()
i TRequestMessage @'ClientToServer a
m ((<~>) @(*) m n -> forall a. n a -> m a
forall {k} (m :: k -> *) (n :: k -> *).
(<~>) @k m n -> forall (a :: k). n a -> m a
backward (<~>) @(*) m n
nat (n () -> m ())
-> (Either
(TResponseError @'ClientToServer a)
(MessageResult @'ClientToServer @'Request a)
-> n ())
-> Either
(TResponseError @'ClientToServer a)
(MessageResult @'ClientToServer @'Request a)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either
(TResponseError @'ClientToServer a)
(MessageResult @'ClientToServer @'Request a)
-> n ()
k))) (\Handler @'ClientToServer @'Notification m a
i TNotificationMessage @'ClientToServer a
m -> (<~>) @(*) m n -> forall a. m a -> n a
forall {k} (m :: k -> *) (n :: k -> *).
(<~>) @k m n -> forall (a :: k). m a -> n a
forward (<~>) @(*) m n
nat (Handler @'ClientToServer @'Notification m a
TNotificationMessage @'ClientToServer a -> m ()
i TNotificationMessage @'ClientToServer a
m))
mapHandlers ::
(forall (a :: Method ClientToServer Request). Handler m a -> Handler n a) ->
(forall (a :: Method ClientToServer Notification). Handler m a -> Handler n a) ->
Handlers m ->
Handlers n
mapHandlers :: forall (m :: * -> *) (n :: * -> *).
(forall (a :: Method 'ClientToServer 'Request).
Handler @'ClientToServer @'Request m a
-> Handler @'ClientToServer @'Request n a)
-> (forall (a :: Method 'ClientToServer 'Notification).
Handler @'ClientToServer @'Notification m a
-> Handler @'ClientToServer @'Notification n a)
-> Handlers m
-> Handlers n
mapHandlers forall (a :: Method 'ClientToServer 'Request).
Handler @'ClientToServer @'Request m a
-> Handler @'ClientToServer @'Request n a
mapReq forall (a :: Method 'ClientToServer 'Notification).
Handler @'ClientToServer @'Notification m a
-> Handler @'ClientToServer @'Notification n a
mapNot (Handlers SMethodMap
@'ClientToServer @'Request (ClientMessageHandler m 'Request)
reqs SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler m 'Notification)
nots) = SMethodMap
@'ClientToServer @'Request (ClientMessageHandler n 'Request)
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler n 'Notification)
-> Handlers n
forall (m :: * -> *).
SMethodMap
@'ClientToServer @'Request (ClientMessageHandler m 'Request)
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler m 'Notification)
-> Handlers m
Handlers SMethodMap
@'ClientToServer @'Request (ClientMessageHandler n 'Request)
reqs' SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler n 'Notification)
nots'
where
reqs' :: SMethodMap
@'ClientToServer @'Request (ClientMessageHandler n 'Request)
reqs' = (forall (a :: Method 'ClientToServer 'Request).
ClientMessageHandler m 'Request a
-> ClientMessageHandler n 'Request a)
-> SMethodMap
@'ClientToServer @'Request (ClientMessageHandler m 'Request)
-> SMethodMap
@'ClientToServer @'Request (ClientMessageHandler n 'Request)
forall {f :: MessageDirection} {t :: MessageKind}
(u :: Method f t -> *) (v :: Method f t -> *).
(forall (a :: Method f t). u a -> v a)
-> SMethodMap @f @t u -> SMethodMap @f @t v
SMethodMap.map (\(ClientMessageHandler Handler @'ClientToServer @'Request m a
i) -> Handler @'ClientToServer @'Request n a
-> ClientMessageHandler n 'Request a
forall (f :: * -> *) (t :: MessageKind)
(m :: Method 'ClientToServer t).
Handler @'ClientToServer @t f m -> ClientMessageHandler f t m
ClientMessageHandler (Handler @'ClientToServer @'Request n a
-> ClientMessageHandler n 'Request a)
-> Handler @'ClientToServer @'Request n a
-> ClientMessageHandler n 'Request a
forall a b. (a -> b) -> a -> b
$ Handler @'ClientToServer @'Request m a
-> Handler @'ClientToServer @'Request n a
forall (a :: Method 'ClientToServer 'Request).
Handler @'ClientToServer @'Request m a
-> Handler @'ClientToServer @'Request n a
mapReq Handler @'ClientToServer @'Request m a
i) SMethodMap
@'ClientToServer @'Request (ClientMessageHandler m 'Request)
reqs
nots' :: SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler n 'Notification)
nots' = (forall (a :: Method 'ClientToServer 'Notification).
ClientMessageHandler m 'Notification a
-> ClientMessageHandler n 'Notification a)
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler m 'Notification)
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler n 'Notification)
forall {f :: MessageDirection} {t :: MessageKind}
(u :: Method f t -> *) (v :: Method f t -> *).
(forall (a :: Method f t). u a -> v a)
-> SMethodMap @f @t u -> SMethodMap @f @t v
SMethodMap.map (\(ClientMessageHandler Handler @'ClientToServer @'Notification m a
i) -> Handler @'ClientToServer @'Notification n a
-> ClientMessageHandler n 'Notification a
forall (f :: * -> *) (t :: MessageKind)
(m :: Method 'ClientToServer t).
Handler @'ClientToServer @t f m -> ClientMessageHandler f t m
ClientMessageHandler (Handler @'ClientToServer @'Notification n a
-> ClientMessageHandler n 'Notification a)
-> Handler @'ClientToServer @'Notification n a
-> ClientMessageHandler n 'Notification a
forall a b. (a -> b) -> a -> b
$ Handler @'ClientToServer @'Notification m a
-> Handler @'ClientToServer @'Notification n a
forall (a :: Method 'ClientToServer 'Notification).
Handler @'ClientToServer @'Notification m a
-> Handler @'ClientToServer @'Notification n a
mapNot Handler @'ClientToServer @'Notification m a
i) SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler m 'Notification)
nots
data LanguageContextState config = LanguageContextState
{ forall config. LanguageContextState config -> TVar VFSData
resVFS :: !(TVar VFSData)
, forall config. LanguageContextState config -> TVar DiagnosticStore
resDiagnostics :: !(TVar DiagnosticStore)
, forall config. LanguageContextState config -> TVar config
resConfig :: !(TVar config)
, forall config.
LanguageContextState config -> TVar [WorkspaceFolder]
resWorkspaceFolders :: !(TVar [WorkspaceFolder])
, forall config. LanguageContextState config -> ProgressData
resProgressData :: !ProgressData
, forall config. LanguageContextState config -> TVar ResponseMap
resPendingResponses :: !(TVar ResponseMap)
, forall config.
LanguageContextState config -> TVar (RegistrationMap 'Notification)
resRegistrationsNot :: !(TVar (RegistrationMap Notification))
, forall config.
LanguageContextState config -> TVar (RegistrationMap 'Request)
resRegistrationsReq :: !(TVar (RegistrationMap Request))
, forall config. LanguageContextState config -> TVar Int32
resLspId :: !(TVar Int32)
, forall config. LanguageContextState config -> Barrier ()
resShutdown :: !(C.Barrier ())
}
type ResponseMap = IxMap LspId (Product SMethod ServerResponseCallback)
type RegistrationMap (t :: MessageKind) = SMethodMap (Product RegistrationId (ClientMessageHandler IO t))
data RegistrationToken (m :: Method ClientToServer t) = RegistrationToken (SMethod m) (RegistrationId m)
newtype RegistrationId (m :: Method ClientToServer t) = RegistrationId Text
deriving (RegistrationId @t m -> RegistrationId @t m -> Bool
(RegistrationId @t m -> RegistrationId @t m -> Bool)
-> (RegistrationId @t m -> RegistrationId @t m -> Bool)
-> Eq (RegistrationId @t m)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (t :: MessageKind) (m :: Method 'ClientToServer t).
RegistrationId @t m -> RegistrationId @t m -> Bool
$c== :: forall (t :: MessageKind) (m :: Method 'ClientToServer t).
RegistrationId @t m -> RegistrationId @t m -> Bool
== :: RegistrationId @t m -> RegistrationId @t m -> Bool
$c/= :: forall (t :: MessageKind) (m :: Method 'ClientToServer t).
RegistrationId @t m -> RegistrationId @t m -> Bool
/= :: RegistrationId @t m -> RegistrationId @t m -> Bool
Eq)
data ProgressData = ProgressData
{ ProgressData -> TVar Int32
progressNextId :: !(TVar Int32)
, ProgressData -> TVar (Map ProgressToken (IO ()))
progressCancel :: !(TVar (Map.Map ProgressToken (IO ())))
}
data VFSData = VFSData
{ VFSData -> VFS
vfsData :: !VFS
, VFSData -> Map String String
reverseMap :: !(Map.Map FilePath FilePath)
}
{-# INLINE modifyState #-}
modifyState :: MonadLsp config m => (LanguageContextState config -> TVar a) -> (a -> a) -> m ()
modifyState :: forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> (a -> a) -> m ()
modifyState LanguageContextState config -> TVar a
sel a -> a
f = do
TVar a
tvarDat <- (LanguageContextState config -> TVar a) -> m (TVar a)
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> m (TVar a)
getStateVar LanguageContextState config -> TVar a
sel
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar a -> (a -> a) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar a
tvarDat a -> a
f
{-# INLINE stateState #-}
stateState :: MonadLsp config m => (LanguageContextState config -> TVar s) -> (s -> (a, s)) -> m a
stateState :: forall config (m :: * -> *) s a.
MonadLsp config m =>
(LanguageContextState config -> TVar s) -> (s -> (a, s)) -> m a
stateState LanguageContextState config -> TVar s
sel s -> (a, s)
f = do
TVar s
tvarDat <- (LanguageContextState config -> TVar s) -> m (TVar s)
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> m (TVar a)
getStateVar LanguageContextState config -> TVar s
sel
IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ STM a -> IO a
forall a. STM a -> IO a
atomically (STM a -> IO a) -> STM a -> IO a
forall a b. (a -> b) -> a -> b
$ TVar s -> (s -> (a, s)) -> STM a
forall s a. TVar s -> (s -> (a, s)) -> STM a
stateTVar TVar s
tvarDat s -> (a, s)
f
{-# INLINE getsState #-}
getsState :: MonadLsp config m => (LanguageContextState config -> TVar a) -> m a
getsState :: forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> m a
getsState LanguageContextState config -> TVar a
f = do
TVar a
tvarDat <- (LanguageContextState config -> TVar a) -> m (TVar a)
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> m (TVar a)
getStateVar LanguageContextState config -> TVar a
f
IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ TVar a -> IO a
forall a. TVar a -> IO a
readTVarIO TVar a
tvarDat
{-# INLINE getStateVar #-}
getStateVar :: MonadLsp config m => (LanguageContextState config -> TVar a) -> m (TVar a)
getStateVar :: forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> m (TVar a)
getStateVar LanguageContextState config -> TVar a
f = LanguageContextState config -> TVar a
f (LanguageContextState config -> TVar a)
-> (LanguageContextEnv config -> LanguageContextState config)
-> LanguageContextEnv config
-> TVar a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextEnv config -> LanguageContextState config
forall config.
LanguageContextEnv config -> LanguageContextState config
resState (LanguageContextEnv config -> TVar a)
-> m (LanguageContextEnv config) -> m (TVar a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (LanguageContextEnv config)
forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
getLspEnv
data Options = Options
{ Options -> Maybe TextDocumentSyncOptions
optTextDocumentSync :: Maybe L.TextDocumentSyncOptions
, Options -> Maybe String
optCompletionTriggerCharacters :: Maybe [Char]
, Options -> Maybe String
optCompletionAllCommitCharacters :: Maybe [Char]
, Options -> Maybe String
optSignatureHelpTriggerCharacters :: Maybe [Char]
, Options -> Maybe String
optSignatureHelpRetriggerCharacters :: Maybe [Char]
, Options -> Maybe [CodeActionKind]
optCodeActionKinds :: Maybe [CodeActionKind]
, Options -> Maybe (NonEmpty Char)
optDocumentOnTypeFormattingTriggerCharacters :: Maybe (NonEmpty Char)
, Options -> Maybe [Text]
optExecuteCommandCommands :: Maybe [Text]
, Options -> Maybe ServerInfo
optServerInfo :: Maybe ServerInfo
, Options -> Bool
optSupportClientInitiatedProgress :: Bool
, Options -> Int
optProgressStartDelay :: Int
, Options -> Int
optProgressUpdateDelay :: Int
}
instance Default Options where
def :: Options
def =
Maybe TextDocumentSyncOptions
-> Maybe String
-> Maybe String
-> Maybe String
-> Maybe String
-> Maybe [CodeActionKind]
-> Maybe (NonEmpty Char)
-> Maybe [Text]
-> Maybe ServerInfo
-> Bool
-> Int
-> Int
-> Options
Options
Maybe TextDocumentSyncOptions
forall a. Maybe a
Nothing
Maybe String
forall a. Maybe a
Nothing
Maybe String
forall a. Maybe a
Nothing
Maybe String
forall a. Maybe a
Nothing
Maybe String
forall a. Maybe a
Nothing
Maybe [CodeActionKind]
forall a. Maybe a
Nothing
Maybe (NonEmpty Char)
forall a. Maybe a
Nothing
Maybe [Text]
forall a. Maybe a
Nothing
Maybe ServerInfo
forall a. Maybe a
Nothing
Bool
False
Int
0
Int
0
defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options
forall a. Default a => a
def
data ServerDefinition config = forall m a.
ServerDefinition
{ forall config. ServerDefinition config -> config
defaultConfig :: config
, forall config. ServerDefinition config -> Text
configSection :: T.Text
, forall config.
ServerDefinition config -> config -> Value -> Either Text config
parseConfig :: config -> J.Value -> Either T.Text config
, ()
onConfigChange :: config -> m ()
, ()
doInitialize :: LanguageContextEnv config -> TMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) a)
, ()
staticHandlers :: ClientCapabilities -> Handlers m
, ()
interpretHandler :: a -> (m <~> IO)
, forall config. ServerDefinition config -> Options
options :: Options
}
newtype ServerResponseCallback (m :: Method ServerToClient Request)
= ServerResponseCallback (Either (TResponseError m) (MessageResult m) -> IO ())
addResponseHandler :: MonadLsp config f => LspId m -> (Product SMethod ServerResponseCallback) m -> f Bool
addResponseHandler :: forall config (f :: * -> *) (m :: Method 'ServerToClient 'Request).
MonadLsp config f =>
LspId @'ServerToClient m
-> Product
@(Method 'ServerToClient 'Request)
(SMethod @'ServerToClient @'Request)
ServerResponseCallback
m
-> f Bool
addResponseHandler LspId @'ServerToClient m
lid Product
@(Method 'ServerToClient 'Request)
(SMethod @'ServerToClient @'Request)
ServerResponseCallback
m
h = do
(LanguageContextState config -> TVar ResponseMap)
-> (ResponseMap -> (Bool, ResponseMap)) -> f Bool
forall config (m :: * -> *) s a.
MonadLsp config m =>
(LanguageContextState config -> TVar s) -> (s -> (a, s)) -> m a
stateState LanguageContextState config -> TVar ResponseMap
forall config. LanguageContextState config -> TVar ResponseMap
resPendingResponses ((ResponseMap -> (Bool, ResponseMap)) -> f Bool)
-> (ResponseMap -> (Bool, ResponseMap)) -> f Bool
forall a b. (a -> b) -> a -> b
$ \ResponseMap
pending ->
case LspId @'ServerToClient m
-> Product
@(Method 'ServerToClient 'Request)
(SMethod @'ServerToClient @'Request)
ServerResponseCallback
m
-> ResponseMap
-> Maybe ResponseMap
forall {a} (k :: a -> *) (m :: a) (f :: a -> *).
IxOrd @a k =>
k m -> f m -> IxMap @a k f -> Maybe (IxMap @a k f)
insertIxMap LspId @'ServerToClient m
lid Product
@(Method 'ServerToClient 'Request)
(SMethod @'ServerToClient @'Request)
ServerResponseCallback
m
h ResponseMap
pending of
Just !ResponseMap
m -> (Bool
True, ResponseMap
m)
Maybe ResponseMap
Nothing -> (Bool
False, ResponseMap
pending)
sendNotification ::
forall (m :: Method ServerToClient Notification) f config.
MonadLsp config f =>
SServerMethod m ->
MessageParams m ->
f ()
sendNotification :: forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
config.
MonadLsp config f =>
SServerMethod @'Notification m
-> MessageParams @'ServerToClient @'Notification m -> f ()
sendNotification SServerMethod @'Notification m
m MessageParams @'ServerToClient @'Notification m
params =
let msg :: TNotificationMessage @'ServerToClient m
msg = Text
-> SServerMethod @'Notification m
-> MessageParams @'ServerToClient @'Notification m
-> TNotificationMessage @'ServerToClient m
forall (f :: MessageDirection) (m :: Method f 'Notification).
Text
-> SMethod @f @'Notification m
-> MessageParams @f @'Notification m
-> TNotificationMessage @f m
TNotificationMessage Text
"2.0" SServerMethod @'Notification m
m MessageParams @'ServerToClient @'Notification m
params
in case SServerMethod @'Notification m -> ServerNotOrReq @'Notification m
forall {t :: MessageKind} (m :: Method 'ServerToClient t).
SServerMethod @t m -> ServerNotOrReq @t m
splitServerMethod SServerMethod @'Notification m
m of
ServerNotOrReq @'Notification m
IsServerNot -> FromServerMessage -> f ()
forall config (m :: * -> *).
MonadLsp config m =>
FromServerMessage -> m ()
sendToClient (FromServerMessage -> f ()) -> FromServerMessage -> f ()
forall a b. (a -> b) -> a -> b
$ TNotificationMessage @'ServerToClient m -> FromServerMessage
forall (m :: Method 'ServerToClient 'Notification).
((TMessage @'ServerToClient @'Notification m :: *)
~ (TNotificationMessage @'ServerToClient m :: *)) =>
TNotificationMessage @'ServerToClient m -> FromServerMessage
fromServerNot TNotificationMessage @'ServerToClient m
msg
ServerNotOrReq @'Notification m
IsServerEither -> FromServerMessage -> f ()
forall config (m :: * -> *).
MonadLsp config m =>
FromServerMessage -> m ()
sendToClient (FromServerMessage -> f ()) -> FromServerMessage -> f ()
forall a b. (a -> b) -> a -> b
$ SServerMethod @'Notification m
-> TMessage @'ServerToClient @'Notification m -> FromServerMessage
forall (t :: MessageKind) (m :: Method 'ServerToClient t)
(a :: Method 'ClientToServer 'Request -> *).
SMethod @'ServerToClient @t m
-> TMessage @'ServerToClient @t m -> FromServerMessage' a
FromServerMess SServerMethod @'Notification m
m (TMessage @'ServerToClient @'Notification m -> FromServerMessage)
-> TMessage @'ServerToClient @'Notification m -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ TNotificationMessage
@'ServerToClient
('Method_CustomMethod @'ServerToClient @'Notification s)
-> TCustomMessage s 'ServerToClient 'Notification
forall (s :: Symbol) (f :: MessageDirection).
TNotificationMessage @f ('Method_CustomMethod @f @'Notification s)
-> TCustomMessage s f 'Notification
NotMess TNotificationMessage @'ServerToClient m
TNotificationMessage
@'ServerToClient
('Method_CustomMethod @'ServerToClient @'Notification s)
msg
sendRequest ::
forall (m :: Method ServerToClient Request) f config.
MonadLsp config f =>
SServerMethod m ->
MessageParams m ->
(Either (TResponseError m) (MessageResult m) -> f ()) ->
f (LspId m)
sendRequest :: forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod @'Request m
-> MessageParams @'ServerToClient @'Request m
-> (Either
(TResponseError @'ServerToClient m)
(MessageResult @'ServerToClient @'Request m)
-> f ())
-> f (LspId @'ServerToClient m)
sendRequest SServerMethod @'Request m
m MessageParams @'ServerToClient @'Request m
params Either
(TResponseError @'ServerToClient m)
(MessageResult @'ServerToClient @'Request m)
-> f ()
resHandler = do
LspId @'ServerToClient m
reqId <- Int32 -> LspId @'ServerToClient m
forall (f :: MessageDirection) (m :: Method f 'Request).
Int32 -> LspId @f m
IdInt (Int32 -> LspId @'ServerToClient m)
-> f Int32 -> f (LspId @'ServerToClient m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Int32
forall config (m :: * -> *). MonadLsp config m => m Int32
freshLspId
f () -> IO ()
rio <- f (f () -> IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
Bool
success <- LspId @'ServerToClient m
-> Product
@(Method 'ServerToClient 'Request)
(SMethod @'ServerToClient @'Request)
ServerResponseCallback
m
-> f Bool
forall config (f :: * -> *) (m :: Method 'ServerToClient 'Request).
MonadLsp config f =>
LspId @'ServerToClient m
-> Product
@(Method 'ServerToClient 'Request)
(SMethod @'ServerToClient @'Request)
ServerResponseCallback
m
-> f Bool
addResponseHandler LspId @'ServerToClient m
reqId (SServerMethod @'Request m
-> ServerResponseCallback m
-> Product
@(Method 'ServerToClient 'Request)
(SMethod @'ServerToClient @'Request)
ServerResponseCallback
m
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product @k f g a
Pair SServerMethod @'Request m
m ((Either
(TResponseError @'ServerToClient m)
(MessageResult @'ServerToClient @'Request m)
-> IO ())
-> ServerResponseCallback m
forall (m :: Method 'ServerToClient 'Request).
(Either
(TResponseError @'ServerToClient m)
(MessageResult @'ServerToClient @'Request m)
-> IO ())
-> ServerResponseCallback m
ServerResponseCallback (f () -> IO ()
rio (f () -> IO ())
-> (Either
(TResponseError @'ServerToClient m)
(MessageResult @'ServerToClient @'Request m)
-> f ())
-> Either
(TResponseError @'ServerToClient m)
(MessageResult @'ServerToClient @'Request m)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either
(TResponseError @'ServerToClient m)
(MessageResult @'ServerToClient @'Request m)
-> f ()
resHandler)))
Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ String -> f ()
forall a. HasCallStack => String -> a
error String
"LSP: could not send FromServer request as id is reused"
let msg :: TRequestMessage @'ServerToClient m
msg = Text
-> LspId @'ServerToClient m
-> SServerMethod @'Request m
-> MessageParams @'ServerToClient @'Request m
-> TRequestMessage @'ServerToClient m
forall (f :: MessageDirection) (m :: Method f 'Request).
Text
-> LspId @f m
-> SMethod @f @'Request m
-> MessageParams @f @'Request m
-> TRequestMessage @f m
TRequestMessage Text
"2.0" LspId @'ServerToClient m
reqId SServerMethod @'Request m
m MessageParams @'ServerToClient @'Request m
params
~() <- case SServerMethod @'Request m -> ServerNotOrReq @'Request m
forall {t :: MessageKind} (m :: Method 'ServerToClient t).
SServerMethod @t m -> ServerNotOrReq @t m
splitServerMethod SServerMethod @'Request m
m of
ServerNotOrReq @'Request m
IsServerReq -> FromServerMessage -> f ()
forall config (m :: * -> *).
MonadLsp config m =>
FromServerMessage -> m ()
sendToClient (FromServerMessage -> f ()) -> FromServerMessage -> f ()
forall a b. (a -> b) -> a -> b
$ TRequestMessage @'ServerToClient m -> FromServerMessage
forall (m :: Method 'ServerToClient 'Request).
((TMessage @'ServerToClient @'Request m :: *)
~ (TRequestMessage @'ServerToClient m :: *)) =>
TRequestMessage @'ServerToClient m -> FromServerMessage
fromServerReq TRequestMessage @'ServerToClient m
msg
ServerNotOrReq @'Request m
IsServerEither -> FromServerMessage -> f ()
forall config (m :: * -> *).
MonadLsp config m =>
FromServerMessage -> m ()
sendToClient (FromServerMessage -> f ()) -> FromServerMessage -> f ()
forall a b. (a -> b) -> a -> b
$ SServerMethod @'Request m
-> TMessage @'ServerToClient @'Request m -> FromServerMessage
forall (t :: MessageKind) (m :: Method 'ServerToClient t)
(a :: Method 'ClientToServer 'Request -> *).
SMethod @'ServerToClient @t m
-> TMessage @'ServerToClient @t m -> FromServerMessage' a
FromServerMess SServerMethod @'Request m
m (TMessage @'ServerToClient @'Request m -> FromServerMessage)
-> TMessage @'ServerToClient @'Request m -> FromServerMessage
forall a b. (a -> b) -> a -> b
$ TRequestMessage
@'ServerToClient
('Method_CustomMethod @'ServerToClient @'Request s)
-> TCustomMessage s 'ServerToClient 'Request
forall (s :: Symbol) (f :: MessageDirection).
TRequestMessage @f ('Method_CustomMethod @f @'Request s)
-> TCustomMessage s f 'Request
ReqMess TRequestMessage @'ServerToClient m
TRequestMessage
@'ServerToClient
('Method_CustomMethod @'ServerToClient @'Request s)
msg
LspId @'ServerToClient m -> f (LspId @'ServerToClient m)
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return LspId @'ServerToClient m
reqId
getVirtualFile :: MonadLsp config m => NormalizedUri -> m (Maybe VirtualFile)
getVirtualFile :: forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
getVirtualFile NormalizedUri
uri = do
VFS
dat <- VFSData -> VFS
vfsData (VFSData -> VFS) -> m VFSData -> m VFS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LanguageContextState config -> TVar VFSData) -> m VFSData
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> m a
getsState LanguageContextState config -> TVar VFSData
forall config. LanguageContextState config -> TVar VFSData
resVFS
Maybe VirtualFile -> m (Maybe VirtualFile)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe VirtualFile -> m (Maybe VirtualFile))
-> Maybe VirtualFile -> m (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ VFS
dat VFS
-> Getting (Maybe VirtualFile) VFS (Maybe VirtualFile)
-> Maybe VirtualFile
forall s a. s -> Getting a s a -> a
^. (Map NormalizedUri VirtualFile
-> Const @(*) (Maybe VirtualFile) (Map NormalizedUri VirtualFile))
-> VFS -> Const @(*) (Maybe VirtualFile) VFS
forall s a. HasVfsMap s a => Lens' s a
Lens' VFS (Map NormalizedUri VirtualFile)
vfsMap ((Map NormalizedUri VirtualFile
-> Const @(*) (Maybe VirtualFile) (Map NormalizedUri VirtualFile))
-> VFS -> Const @(*) (Maybe VirtualFile) VFS)
-> ((Maybe VirtualFile
-> Const @(*) (Maybe VirtualFile) (Maybe VirtualFile))
-> Map NormalizedUri VirtualFile
-> Const @(*) (Maybe VirtualFile) (Map NormalizedUri VirtualFile))
-> Getting (Maybe VirtualFile) VFS (Maybe VirtualFile)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map NormalizedUri VirtualFile)
-> Lens'
(Map NormalizedUri VirtualFile)
(Maybe (IxValue (Map NormalizedUri VirtualFile)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map NormalizedUri VirtualFile)
NormalizedUri
uri
{-# INLINE getVirtualFile #-}
getVirtualFiles :: MonadLsp config m => m VFS
getVirtualFiles :: forall config (m :: * -> *). MonadLsp config m => m VFS
getVirtualFiles = VFSData -> VFS
vfsData (VFSData -> VFS) -> m VFSData -> m VFS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LanguageContextState config -> TVar VFSData) -> m VFSData
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> m a
getsState LanguageContextState config -> TVar VFSData
forall config. LanguageContextState config -> TVar VFSData
resVFS
{-# INLINE getVirtualFiles #-}
snapshotVirtualFiles :: LanguageContextEnv c -> STM VFS
snapshotVirtualFiles :: forall c. LanguageContextEnv c -> STM VFS
snapshotVirtualFiles LanguageContextEnv c
env = VFSData -> VFS
vfsData (VFSData -> VFS) -> STM VFSData -> STM VFS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar VFSData -> STM VFSData
forall a. TVar a -> STM a
readTVar (LanguageContextState c -> TVar VFSData
forall config. LanguageContextState config -> TVar VFSData
resVFS (LanguageContextState c -> TVar VFSData)
-> LanguageContextState c -> TVar VFSData
forall a b. (a -> b) -> a -> b
$ LanguageContextEnv c -> LanguageContextState c
forall config.
LanguageContextEnv config -> LanguageContextState config
resState LanguageContextEnv c
env)
{-# INLINE snapshotVirtualFiles #-}
persistVirtualFile :: MonadLsp config m => LogAction m (WithSeverity VfsLog) -> FilePath -> NormalizedUri -> m (Maybe FilePath)
persistVirtualFile :: forall config (m :: * -> *).
MonadLsp config m =>
LogAction m (WithSeverity VfsLog)
-> String -> NormalizedUri -> m (Maybe String)
persistVirtualFile LogAction m (WithSeverity VfsLog)
logger String
dir NormalizedUri
uri = do
m (m (Maybe String)) -> m (Maybe String)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m (Maybe String)) -> m (Maybe String))
-> m (m (Maybe String)) -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ (LanguageContextState config -> TVar VFSData)
-> (VFSData -> (m (Maybe String), VFSData)) -> m (m (Maybe String))
forall config (m :: * -> *) s a.
MonadLsp config m =>
(LanguageContextState config -> TVar s) -> (s -> (a, s)) -> m a
stateState LanguageContextState config -> TVar VFSData
forall config. LanguageContextState config -> TVar VFSData
resVFS ((VFSData -> (m (Maybe String), VFSData)) -> m (m (Maybe String)))
-> (VFSData -> (m (Maybe String), VFSData)) -> m (m (Maybe String))
forall a b. (a -> b) -> a -> b
$ \VFSData
vfs ->
case LogAction m (WithSeverity VfsLog)
-> String -> VFS -> NormalizedUri -> Maybe (String, m ())
forall (m :: * -> *).
MonadIO m =>
LogAction m (WithSeverity VfsLog)
-> String -> VFS -> NormalizedUri -> Maybe (String, m ())
persistFileVFS LogAction m (WithSeverity VfsLog)
logger String
dir (VFSData -> VFS
vfsData VFSData
vfs) NormalizedUri
uri of
Maybe (String, m ())
Nothing -> (Maybe String -> m (Maybe String)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing, VFSData
vfs)
Just (String
fn, m ()
write) ->
let !revMap :: Map String String
revMap = case Uri -> Maybe String
uriToFilePath (NormalizedUri -> Uri
fromNormalizedUri NormalizedUri
uri) of
Just String
uri_fp -> String -> String -> Map String String -> Map String String
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
fn String
uri_fp (Map String String -> Map String String)
-> Map String String -> Map String String
forall a b. (a -> b) -> a -> b
$ VFSData -> Map String String
reverseMap VFSData
vfs
Maybe String
Nothing -> VFSData -> Map String String
reverseMap VFSData
vfs
!vfs' :: VFSData
vfs' = VFSData
vfs{reverseMap = revMap}
act :: m (Maybe String)
act = do
m ()
write
Maybe String -> m (Maybe String)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String
forall a. a -> Maybe a
Just String
fn)
in (m (Maybe String)
act, VFSData
vfs')
getVersionedTextDoc :: MonadLsp config m => TextDocumentIdentifier -> m VersionedTextDocumentIdentifier
getVersionedTextDoc :: forall config (m :: * -> *).
MonadLsp config m =>
TextDocumentIdentifier -> m VersionedTextDocumentIdentifier
getVersionedTextDoc TextDocumentIdentifier
doc = do
let uri :: Uri
uri = TextDocumentIdentifier
doc TextDocumentIdentifier
-> Getting Uri TextDocumentIdentifier Uri -> Uri
forall s a. s -> Getting a s a -> a
^. Getting Uri TextDocumentIdentifier Uri
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
L.uri
Maybe VirtualFile
mvf <- NormalizedUri -> m (Maybe VirtualFile)
forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
getVirtualFile (Uri -> NormalizedUri
toNormalizedUri Uri
uri)
let ver :: Int32
ver = case Maybe VirtualFile
mvf of
Just (VirtualFile Int32
lspver Int
_ Rope
_) -> Int32
lspver
Maybe VirtualFile
Nothing -> Int32
0
VersionedTextDocumentIdentifier
-> m VersionedTextDocumentIdentifier
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Uri -> Int32 -> VersionedTextDocumentIdentifier
VersionedTextDocumentIdentifier Uri
uri Int32
ver)
{-# INLINE getVersionedTextDoc #-}
reverseFileMap :: MonadLsp config m => m (FilePath -> FilePath)
reverseFileMap :: forall config (m :: * -> *). MonadLsp config m => m ShowS
reverseFileMap = do
VFSData
vfs <- (LanguageContextState config -> TVar VFSData) -> m VFSData
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> m a
getsState LanguageContextState config -> TVar VFSData
forall config. LanguageContextState config -> TVar VFSData
resVFS
let f :: ShowS
f String
fp = String -> String -> Map String String -> String
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault String
fp String
fp (Map String String -> String) -> Map String String -> String
forall a b. (a -> b) -> a -> b
$ VFSData -> Map String String
reverseMap VFSData
vfs
ShowS -> m ShowS
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ShowS
f
{-# INLINE reverseFileMap #-}
sendToClient :: MonadLsp config m => FromServerMessage -> m ()
sendToClient :: forall config (m :: * -> *).
MonadLsp config m =>
FromServerMessage -> m ()
sendToClient FromServerMessage
msg = do
FromServerMessage -> IO ()
f <- LanguageContextEnv config -> FromServerMessage -> IO ()
forall config.
LanguageContextEnv config -> FromServerMessage -> IO ()
resSendMessage (LanguageContextEnv config -> FromServerMessage -> IO ())
-> m (LanguageContextEnv config) -> m (FromServerMessage -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (LanguageContextEnv config)
forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
getLspEnv
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FromServerMessage -> IO ()
f FromServerMessage
msg
{-# INLINE sendToClient #-}
freshLspId :: MonadLsp config m => m Int32
freshLspId :: forall config (m :: * -> *). MonadLsp config m => m Int32
freshLspId = do
(LanguageContextState config -> TVar Int32)
-> (Int32 -> (Int32, Int32)) -> m Int32
forall config (m :: * -> *) s a.
MonadLsp config m =>
(LanguageContextState config -> TVar s) -> (s -> (a, s)) -> m a
stateState LanguageContextState config -> TVar Int32
forall config. LanguageContextState config -> TVar Int32
resLspId ((Int32 -> (Int32, Int32)) -> m Int32)
-> (Int32 -> (Int32, Int32)) -> m Int32
forall a b. (a -> b) -> a -> b
$ \Int32
cur ->
let !next :: Int32
next = Int32
cur Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
1 in (Int32
cur, Int32
next)
{-# INLINE freshLspId #-}
getConfig :: MonadLsp config m => m config
getConfig :: forall config (m :: * -> *). MonadLsp config m => m config
getConfig = (LanguageContextState config -> TVar config) -> m config
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> m a
getsState LanguageContextState config -> TVar config
forall config. LanguageContextState config -> TVar config
resConfig
{-# INLINE getConfig #-}
setConfig :: MonadLsp config m => config -> m ()
setConfig :: forall config (m :: * -> *). MonadLsp config m => config -> m ()
setConfig config
config = (LanguageContextState config -> TVar config)
-> (config -> ((), config)) -> m ()
forall config (m :: * -> *) s a.
MonadLsp config m =>
(LanguageContextState config -> TVar s) -> (s -> (a, s)) -> m a
stateState LanguageContextState config -> TVar config
forall config. LanguageContextState config -> TVar config
resConfig (((), config) -> config -> ((), config)
forall a b. a -> b -> a
const ((), config
config))
{-# INLINE setConfig #-}
getClientCapabilities :: MonadLsp config m => m L.ClientCapabilities
getClientCapabilities :: forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
getClientCapabilities = LanguageContextEnv config -> ClientCapabilities
forall config. LanguageContextEnv config -> ClientCapabilities
resClientCapabilities (LanguageContextEnv config -> ClientCapabilities)
-> m (LanguageContextEnv config) -> m ClientCapabilities
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (LanguageContextEnv config)
forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
getLspEnv
{-# INLINE getClientCapabilities #-}
getRootPath :: MonadLsp config m => m (Maybe FilePath)
getRootPath :: forall config (m :: * -> *). MonadLsp config m => m (Maybe String)
getRootPath = LanguageContextEnv config -> Maybe String
forall config. LanguageContextEnv config -> Maybe String
resRootPath (LanguageContextEnv config -> Maybe String)
-> m (LanguageContextEnv config) -> m (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (LanguageContextEnv config)
forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
getLspEnv
{-# INLINE getRootPath #-}
getWorkspaceFolders :: MonadLsp config m => m (Maybe [WorkspaceFolder])
getWorkspaceFolders :: forall config (m :: * -> *).
MonadLsp config m =>
m (Maybe [WorkspaceFolder])
getWorkspaceFolders = do
ClientCapabilities
clientCaps <- m ClientCapabilities
forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
getClientCapabilities
let clientSupportsWfs :: Bool
clientSupportsWfs = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ClientCapabilities
clientCaps ClientCapabilities
-> Getting (First Bool) ClientCapabilities Bool -> Maybe Bool
forall s a. s -> Getting (First a) s a -> Maybe a
^? (Maybe WorkspaceClientCapabilities
-> Const @(*) (First Bool) (Maybe WorkspaceClientCapabilities))
-> ClientCapabilities -> Const @(*) (First Bool) ClientCapabilities
forall s a. HasWorkspace s a => Lens' s a
Lens' ClientCapabilities (Maybe WorkspaceClientCapabilities)
L.workspace ((Maybe WorkspaceClientCapabilities
-> Const @(*) (First Bool) (Maybe WorkspaceClientCapabilities))
-> ClientCapabilities
-> Const @(*) (First Bool) ClientCapabilities)
-> ((Bool -> Const @(*) (First Bool) Bool)
-> Maybe WorkspaceClientCapabilities
-> Const @(*) (First Bool) (Maybe WorkspaceClientCapabilities))
-> Getting (First Bool) ClientCapabilities Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WorkspaceClientCapabilities
-> Const @(*) (First Bool) WorkspaceClientCapabilities)
-> Maybe WorkspaceClientCapabilities
-> Const @(*) (First Bool) (Maybe WorkspaceClientCapabilities)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((WorkspaceClientCapabilities
-> Const @(*) (First Bool) WorkspaceClientCapabilities)
-> Maybe WorkspaceClientCapabilities
-> Const @(*) (First Bool) (Maybe WorkspaceClientCapabilities))
-> ((Bool -> Const @(*) (First Bool) Bool)
-> WorkspaceClientCapabilities
-> Const @(*) (First Bool) WorkspaceClientCapabilities)
-> (Bool -> Const @(*) (First Bool) Bool)
-> Maybe WorkspaceClientCapabilities
-> Const @(*) (First Bool) (Maybe WorkspaceClientCapabilities)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Const @(*) (First Bool) (Maybe Bool))
-> WorkspaceClientCapabilities
-> Const @(*) (First Bool) WorkspaceClientCapabilities
forall s a. HasWorkspaceFolders s a => Lens' s a
Lens' WorkspaceClientCapabilities (Maybe Bool)
L.workspaceFolders ((Maybe Bool -> Const @(*) (First Bool) (Maybe Bool))
-> WorkspaceClientCapabilities
-> Const @(*) (First Bool) WorkspaceClientCapabilities)
-> ((Bool -> Const @(*) (First Bool) Bool)
-> Maybe Bool -> Const @(*) (First Bool) (Maybe Bool))
-> (Bool -> Const @(*) (First Bool) Bool)
-> WorkspaceClientCapabilities
-> Const @(*) (First Bool) WorkspaceClientCapabilities
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Const @(*) (First Bool) Bool)
-> Maybe Bool -> Const @(*) (First Bool) (Maybe Bool)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just
if Bool
clientSupportsWfs
then [WorkspaceFolder] -> Maybe [WorkspaceFolder]
forall a. a -> Maybe a
Just ([WorkspaceFolder] -> Maybe [WorkspaceFolder])
-> m [WorkspaceFolder] -> m (Maybe [WorkspaceFolder])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LanguageContextState config -> TVar [WorkspaceFolder])
-> m [WorkspaceFolder]
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> m a
getsState LanguageContextState config -> TVar [WorkspaceFolder]
forall config.
LanguageContextState config -> TVar [WorkspaceFolder]
resWorkspaceFolders
else Maybe [WorkspaceFolder] -> m (Maybe [WorkspaceFolder])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [WorkspaceFolder]
forall a. Maybe a
Nothing
{-# INLINE getWorkspaceFolders #-}
registerCapability ::
forall f t (m :: Method ClientToServer t) config.
MonadLsp config f =>
LogAction f (WithSeverity LspCoreLog) ->
SClientMethod m ->
RegistrationOptions m ->
Handler f m ->
f (Maybe (RegistrationToken m))
registerCapability :: forall (f :: * -> *) (t :: MessageKind)
(m :: Method 'ClientToServer t) config.
MonadLsp config f =>
LogAction f (WithSeverity LspCoreLog)
-> SClientMethod @t m
-> RegistrationOptions @'ClientToServer @t m
-> Handler @'ClientToServer @t f m
-> f (Maybe (RegistrationToken @t m))
registerCapability LogAction f (WithSeverity LspCoreLog)
logger SClientMethod @t m
method RegistrationOptions @'ClientToServer @t m
regOpts Handler @'ClientToServer @t f m
f = do
Handlers IO
handlers <- LanguageContextEnv config -> Handlers IO
forall config. LanguageContextEnv config -> Handlers IO
resHandlers (LanguageContextEnv config -> Handlers IO)
-> f (LanguageContextEnv config) -> f (Handlers IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (LanguageContextEnv config)
forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
getLspEnv
let alreadyStaticallyRegistered :: Bool
alreadyStaticallyRegistered = case SClientMethod @t m -> ClientNotOrReq @t m
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> ClientNotOrReq @t m
splitClientMethod SClientMethod @t m
method of
ClientNotOrReq @t m
IsClientNot -> SClientMethod @t m
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler IO 'Notification)
-> Bool
forall {f1 :: MessageDirection} {t1 :: MessageKind}
{f2 :: MessageDirection} {t2 :: MessageKind} (a :: Method f1 t1)
(v :: Method f2 t2 -> *).
SMethod @f1 @t1 a -> SMethodMap @f2 @t2 v -> Bool
SMethodMap.member SClientMethod @t m
method (SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler IO 'Notification)
-> Bool)
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler IO 'Notification)
-> Bool
forall a b. (a -> b) -> a -> b
$ Handlers IO
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler IO 'Notification)
forall (m :: * -> *).
Handlers m
-> SMethodMap
@'ClientToServer
@'Notification
(ClientMessageHandler m 'Notification)
notHandlers Handlers IO
handlers
ClientNotOrReq @t m
IsClientReq -> SClientMethod @t m
-> SMethodMap
@'ClientToServer @'Request (ClientMessageHandler IO 'Request)
-> Bool
forall {f1 :: MessageDirection} {t1 :: MessageKind}
{f2 :: MessageDirection} {t2 :: MessageKind} (a :: Method f1 t1)
(v :: Method f2 t2 -> *).
SMethod @f1 @t1 a -> SMethodMap @f2 @t2 v -> Bool
SMethodMap.member SClientMethod @t m
method (SMethodMap
@'ClientToServer @'Request (ClientMessageHandler IO 'Request)
-> Bool)
-> SMethodMap
@'ClientToServer @'Request (ClientMessageHandler IO 'Request)
-> Bool
forall a b. (a -> b) -> a -> b
$ Handlers IO
-> SMethodMap
@'ClientToServer @'Request (ClientMessageHandler IO 'Request)
forall (m :: * -> *).
Handlers m
-> SMethodMap
@'ClientToServer @'Request (ClientMessageHandler m 'Request)
reqHandlers Handlers IO
handlers
ClientNotOrReq @t m
IsClientEither -> String -> Bool
forall a. HasCallStack => String -> a
error String
"Cannot register capability for custom methods"
Bool -> f (Maybe (RegistrationToken @t m))
go Bool
alreadyStaticallyRegistered
where
go :: Bool -> f (Maybe (RegistrationToken @t m))
go Bool
True = Maybe (RegistrationToken @t m)
-> f (Maybe (RegistrationToken @t m))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (RegistrationToken @t m)
forall a. Maybe a
Nothing
go Bool
False = do
UnliftIO f
rio <- f (UnliftIO f)
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
Maybe (RegistrationToken @t m)
mtoken <- LogAction f (WithSeverity LspCoreLog)
-> SClientMethod @t m
-> RegistrationOptions @'ClientToServer @t m
-> f (Maybe (RegistrationToken @t m))
forall (f :: * -> *) (t :: MessageKind)
(m :: Method 'ClientToServer t) config.
MonadLsp config f =>
LogAction f (WithSeverity LspCoreLog)
-> SClientMethod @t m
-> RegistrationOptions @'ClientToServer @t m
-> f (Maybe (RegistrationToken @t m))
trySendRegistration LogAction f (WithSeverity LspCoreLog)
logger SClientMethod @t m
method RegistrationOptions @'ClientToServer @t m
regOpts
case Maybe (RegistrationToken @t m)
mtoken of
Just token :: RegistrationToken @t m
token@(RegistrationToken SClientMethod @t m
_ RegistrationId @t m
regId) -> do
~() <- case SClientMethod @t m -> ClientNotOrReq @t m
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> ClientNotOrReq @t m
splitClientMethod SClientMethod @t m
method of
ClientNotOrReq @t m
IsClientNot -> (LanguageContextState config
-> TVar (RegistrationMap 'Notification))
-> (RegistrationMap 'Notification -> RegistrationMap 'Notification)
-> f ()
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> (a -> a) -> m ()
modifyState LanguageContextState config -> TVar (RegistrationMap 'Notification)
forall config.
LanguageContextState config -> TVar (RegistrationMap 'Notification)
resRegistrationsNot ((RegistrationMap 'Notification -> RegistrationMap 'Notification)
-> f ())
-> (RegistrationMap 'Notification -> RegistrationMap 'Notification)
-> f ()
forall a b. (a -> b) -> a -> b
$ \RegistrationMap 'Notification
oldRegs ->
let pair :: Product
@(Method 'ClientToServer t)
(RegistrationId @t)
(ClientMessageHandler IO t)
m
pair = RegistrationId @t m
-> ClientMessageHandler IO t m
-> Product
@(Method 'ClientToServer t)
(RegistrationId @t)
(ClientMessageHandler IO t)
m
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product @k f g a
Pair RegistrationId @t m
regId (Handler @'ClientToServer @t IO m -> ClientMessageHandler IO t m
forall (f :: * -> *) (t :: MessageKind)
(m :: Method 'ClientToServer t).
Handler @'ClientToServer @t f m -> ClientMessageHandler f t m
ClientMessageHandler (UnliftIO f -> forall a. f a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO f
rio (f () -> IO ())
-> (TNotificationMessage @'ClientToServer m -> f ())
-> TNotificationMessage @'ClientToServer m
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handler @'ClientToServer @t f m
TNotificationMessage @'ClientToServer m -> f ()
f))
in SMethod @'ClientToServer @'Notification m
-> Product
@(Method 'ClientToServer 'Notification)
(RegistrationId @'Notification)
(ClientMessageHandler IO 'Notification)
m
-> RegistrationMap 'Notification
-> RegistrationMap 'Notification
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
(v :: Method f t -> *).
SMethod @f @t a -> v a -> SMethodMap @f @t v -> SMethodMap @f @t v
SMethodMap.insert SClientMethod @t m
SMethod @'ClientToServer @'Notification m
method Product
@(Method 'ClientToServer t)
(RegistrationId @t)
(ClientMessageHandler IO t)
m
Product
@(Method 'ClientToServer 'Notification)
(RegistrationId @'Notification)
(ClientMessageHandler IO 'Notification)
m
pair RegistrationMap 'Notification
oldRegs
ClientNotOrReq @t m
IsClientReq -> (LanguageContextState config -> TVar (RegistrationMap 'Request))
-> (RegistrationMap 'Request -> RegistrationMap 'Request) -> f ()
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> (a -> a) -> m ()
modifyState LanguageContextState config -> TVar (RegistrationMap 'Request)
forall config.
LanguageContextState config -> TVar (RegistrationMap 'Request)
resRegistrationsReq ((RegistrationMap 'Request -> RegistrationMap 'Request) -> f ())
-> (RegistrationMap 'Request -> RegistrationMap 'Request) -> f ()
forall a b. (a -> b) -> a -> b
$ \RegistrationMap 'Request
oldRegs ->
let pair :: Product
@(Method 'ClientToServer t)
(RegistrationId @t)
(ClientMessageHandler IO t)
m
pair = RegistrationId @t m
-> ClientMessageHandler IO t m
-> Product
@(Method 'ClientToServer t)
(RegistrationId @t)
(ClientMessageHandler IO t)
m
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product @k f g a
Pair RegistrationId @t m
regId (Handler @'ClientToServer @t IO m -> ClientMessageHandler IO t m
forall (f :: * -> *) (t :: MessageKind)
(m :: Method 'ClientToServer t).
Handler @'ClientToServer @t f m -> ClientMessageHandler f t m
ClientMessageHandler (\TRequestMessage @'ClientToServer m
msg Either
(TResponseError @'ClientToServer m)
(MessageResult @'ClientToServer @'Request m)
-> IO ()
k -> UnliftIO f -> forall a. f a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO f
rio (f () -> IO ()) -> f () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handler @'ClientToServer @t f m
TRequestMessage @'ClientToServer m
-> (Either
(TResponseError @'ClientToServer m)
(MessageResult @'ClientToServer @'Request m)
-> f ())
-> f ()
f TRequestMessage @'ClientToServer m
msg (IO () -> f ()
forall a. IO a -> f a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> f ())
-> (Either
(TResponseError @'ClientToServer m)
(MessageResult @'ClientToServer @'Request m)
-> IO ())
-> Either
(TResponseError @'ClientToServer m)
(MessageResult @'ClientToServer @'Request m)
-> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either
(TResponseError @'ClientToServer m)
(MessageResult @'ClientToServer @'Request m)
-> IO ()
k)))
in SMethod @'ClientToServer @'Request m
-> Product
@(Method 'ClientToServer 'Request)
(RegistrationId @'Request)
(ClientMessageHandler IO 'Request)
m
-> RegistrationMap 'Request
-> RegistrationMap 'Request
forall {f :: MessageDirection} {t :: MessageKind} (a :: Method f t)
(v :: Method f t -> *).
SMethod @f @t a -> v a -> SMethodMap @f @t v -> SMethodMap @f @t v
SMethodMap.insert SClientMethod @t m
SMethod @'ClientToServer @'Request m
method Product
@(Method 'ClientToServer t)
(RegistrationId @t)
(ClientMessageHandler IO t)
m
Product
@(Method 'ClientToServer 'Request)
(RegistrationId @'Request)
(ClientMessageHandler IO 'Request)
m
pair RegistrationMap 'Request
oldRegs
ClientNotOrReq @t m
IsClientEither -> String -> f ()
forall a. HasCallStack => String -> a
error String
"Cannot register capability for custom methods"
Maybe (RegistrationToken @t m)
-> f (Maybe (RegistrationToken @t m))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (RegistrationToken @t m)
-> f (Maybe (RegistrationToken @t m)))
-> Maybe (RegistrationToken @t m)
-> f (Maybe (RegistrationToken @t m))
forall a b. (a -> b) -> a -> b
$ RegistrationToken @t m -> Maybe (RegistrationToken @t m)
forall a. a -> Maybe a
Just RegistrationToken @t m
token
Maybe (RegistrationToken @t m)
Nothing -> Maybe (RegistrationToken @t m)
-> f (Maybe (RegistrationToken @t m))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (RegistrationToken @t m)
forall a. Maybe a
Nothing
trySendRegistration ::
forall f t (m :: Method ClientToServer t) config.
MonadLsp config f =>
LogAction f (WithSeverity LspCoreLog) ->
SClientMethod m ->
RegistrationOptions m ->
f (Maybe (RegistrationToken m))
trySendRegistration :: forall (f :: * -> *) (t :: MessageKind)
(m :: Method 'ClientToServer t) config.
MonadLsp config f =>
LogAction f (WithSeverity LspCoreLog)
-> SClientMethod @t m
-> RegistrationOptions @'ClientToServer @t m
-> f (Maybe (RegistrationToken @t m))
trySendRegistration LogAction f (WithSeverity LspCoreLog)
logger SClientMethod @t m
method RegistrationOptions @'ClientToServer @t m
regOpts = do
ClientCapabilities
clientCaps <- LanguageContextEnv config -> ClientCapabilities
forall config. LanguageContextEnv config -> ClientCapabilities
resClientCapabilities (LanguageContextEnv config -> ClientCapabilities)
-> f (LanguageContextEnv config) -> f ClientCapabilities
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (LanguageContextEnv config)
forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
getLspEnv
if SClientMethod @t m -> ClientCapabilities -> Bool
forall {f :: MessageDirection} {t :: MessageKind}
(m :: Method f t).
SMethod @f @t m -> ClientCapabilities -> Bool
dynamicRegistrationSupported SClientMethod @t m
method ClientCapabilities
clientCaps
then do
Text
rid <- String -> Text
T.pack (String -> Text) -> (Int32 -> String) -> Int32 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> String
forall a. Show a => a -> String
show (Int32 -> Text) -> f Int32 -> f Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Int32
forall config (m :: * -> *). MonadLsp config m => m Int32
freshLspId
let registration :: TRegistration @t m
registration = Text
-> SClientMethod @t m
-> Maybe (RegistrationOptions @'ClientToServer @t m)
-> TRegistration @t m
forall (t :: MessageKind) (m :: Method 'ClientToServer t).
Text
-> SClientMethod @t m
-> Maybe (RegistrationOptions @'ClientToServer @t m)
-> TRegistration @t m
L.TRegistration Text
rid SClientMethod @t m
method (RegistrationOptions @'ClientToServer @t m
-> Maybe (RegistrationOptions @'ClientToServer @t m)
forall a. a -> Maybe a
Just RegistrationOptions @'ClientToServer @t m
regOpts)
params :: RegistrationParams
params = [Registration] -> RegistrationParams
L.RegistrationParams [TRegistration @t m -> Registration
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
TRegistration @t m -> Registration
toUntypedRegistration TRegistration @t m
registration]
regId :: RegistrationId @t m
regId = Text -> RegistrationId @t m
forall (t :: MessageKind) (m :: Method 'ClientToServer t).
Text -> RegistrationId @t m
RegistrationId Text
rid
LspId @'ServerToClient 'Method_ClientRegisterCapability
_ <- SServerMethod @'Request 'Method_ClientRegisterCapability
-> MessageParams
@'ServerToClient @'Request 'Method_ClientRegisterCapability
-> (Either
(TResponseError @'ServerToClient 'Method_ClientRegisterCapability)
(MessageResult
@'ServerToClient @'Request 'Method_ClientRegisterCapability)
-> f ())
-> f (LspId @'ServerToClient 'Method_ClientRegisterCapability)
forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod @'Request m
-> MessageParams @'ServerToClient @'Request m
-> (Either
(TResponseError @'ServerToClient m)
(MessageResult @'ServerToClient @'Request m)
-> f ())
-> f (LspId @'ServerToClient m)
sendRequest SServerMethod @'Request 'Method_ClientRegisterCapability
SMethod_ClientRegisterCapability RegistrationParams
MessageParams
@'ServerToClient @'Request 'Method_ClientRegisterCapability
params ((Either
(TResponseError @'ServerToClient 'Method_ClientRegisterCapability)
(MessageResult
@'ServerToClient @'Request 'Method_ClientRegisterCapability)
-> f ())
-> f (LspId @'ServerToClient 'Method_ClientRegisterCapability))
-> (Either
(TResponseError @'ServerToClient 'Method_ClientRegisterCapability)
(MessageResult
@'ServerToClient @'Request 'Method_ClientRegisterCapability)
-> f ())
-> f (LspId @'ServerToClient 'Method_ClientRegisterCapability)
forall a b. (a -> b) -> a -> b
$ \Either
(TResponseError @'ServerToClient 'Method_ClientRegisterCapability)
(MessageResult
@'ServerToClient @'Request 'Method_ClientRegisterCapability)
_res -> () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Maybe (RegistrationToken @t m)
-> f (Maybe (RegistrationToken @t m))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RegistrationToken @t m -> Maybe (RegistrationToken @t m)
forall a. a -> Maybe a
Just (RegistrationToken @t m -> Maybe (RegistrationToken @t m))
-> RegistrationToken @t m -> Maybe (RegistrationToken @t m)
forall a b. (a -> b) -> a -> b
$ SClientMethod @t m -> RegistrationId @t m -> RegistrationToken @t m
forall (t :: MessageKind) (m :: Method 'ClientToServer t).
SMethod @'ClientToServer @t m
-> RegistrationId @t m -> RegistrationToken @t m
RegistrationToken SClientMethod @t m
method RegistrationId @t m
regId)
else do
LogAction f (WithSeverity LspCoreLog)
logger LogAction f (WithSeverity LspCoreLog)
-> WithSeverity LspCoreLog -> f ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& SMethod
@'ClientToServer
@'Notification
'Method_WorkspaceDidChangeConfiguration
-> LspCoreLog
forall {f :: MessageDirection} {t :: MessageKind}
(m :: Method f t).
SMethod @f @t m -> LspCoreLog
CantRegister SMethod
@'ClientToServer
@'Notification
'Method_WorkspaceDidChangeConfiguration
SMethod_WorkspaceDidChangeConfiguration LspCoreLog -> Severity -> WithSeverity LspCoreLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Warning
Maybe (RegistrationToken @t m)
-> f (Maybe (RegistrationToken @t m))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (RegistrationToken @t m)
forall a. Maybe a
Nothing
unregisterCapability :: MonadLsp config f => RegistrationToken m -> f ()
unregisterCapability :: forall {t :: MessageKind} config (f :: * -> *)
(m :: Method 'ClientToServer t).
MonadLsp config f =>
RegistrationToken @t m -> f ()
unregisterCapability (RegistrationToken SMethod @'ClientToServer @t m
m (RegistrationId Text
uuid)) = do
~() <- case SMethod @'ClientToServer @t m -> ClientNotOrReq @t m
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
SClientMethod @t m -> ClientNotOrReq @t m
splitClientMethod SMethod @'ClientToServer @t m
m of
ClientNotOrReq @t m
IsClientReq -> (LanguageContextState config -> TVar (RegistrationMap 'Request))
-> (RegistrationMap 'Request -> RegistrationMap 'Request) -> f ()
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> (a -> a) -> m ()
modifyState LanguageContextState config -> TVar (RegistrationMap 'Request)
forall config.
LanguageContextState config -> TVar (RegistrationMap 'Request)
resRegistrationsReq ((RegistrationMap 'Request -> RegistrationMap 'Request) -> f ())
-> (RegistrationMap 'Request -> RegistrationMap 'Request) -> f ()
forall a b. (a -> b) -> a -> b
$ SMethod @'ClientToServer @t m
-> RegistrationMap 'Request -> RegistrationMap 'Request
forall {f1 :: MessageDirection} {t1 :: MessageKind}
{f2 :: MessageDirection} {t2 :: MessageKind} (a :: Method f1 t1)
(v :: Method f2 t2 -> *).
SMethod @f1 @t1 a -> SMethodMap @f2 @t2 v -> SMethodMap @f2 @t2 v
SMethodMap.delete SMethod @'ClientToServer @t m
m
ClientNotOrReq @t m
IsClientNot -> (LanguageContextState config
-> TVar (RegistrationMap 'Notification))
-> (RegistrationMap 'Notification -> RegistrationMap 'Notification)
-> f ()
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> (a -> a) -> m ()
modifyState LanguageContextState config -> TVar (RegistrationMap 'Notification)
forall config.
LanguageContextState config -> TVar (RegistrationMap 'Notification)
resRegistrationsNot ((RegistrationMap 'Notification -> RegistrationMap 'Notification)
-> f ())
-> (RegistrationMap 'Notification -> RegistrationMap 'Notification)
-> f ()
forall a b. (a -> b) -> a -> b
$ SMethod @'ClientToServer @t m
-> RegistrationMap 'Notification -> RegistrationMap 'Notification
forall {f1 :: MessageDirection} {t1 :: MessageKind}
{f2 :: MessageDirection} {t2 :: MessageKind} (a :: Method f1 t1)
(v :: Method f2 t2 -> *).
SMethod @f1 @t1 a -> SMethodMap @f2 @t2 v -> SMethodMap @f2 @t2 v
SMethodMap.delete SMethod @'ClientToServer @t m
m
ClientNotOrReq @t m
IsClientEither -> String -> f ()
forall a. HasCallStack => String -> a
error String
"Cannot unregister capability for custom methods"
let unregistration :: TUnregistration @t m
unregistration = Text -> SMethod @'ClientToServer @t m -> TUnregistration @t m
forall (t :: MessageKind) (m :: Method 'ClientToServer t).
Text -> SMethod @'ClientToServer @t m -> TUnregistration @t m
L.TUnregistration Text
uuid SMethod @'ClientToServer @t m
m
params :: UnregistrationParams
params = [Unregistration] -> UnregistrationParams
L.UnregistrationParams [TUnregistration @t m -> Unregistration
forall {t :: MessageKind} (m :: Method 'ClientToServer t).
TUnregistration @t m -> Unregistration
toUntypedUnregistration TUnregistration @t m
unregistration]
f (LspId @'ServerToClient 'Method_ClientUnregisterCapability)
-> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (f (LspId @'ServerToClient 'Method_ClientUnregisterCapability)
-> f ())
-> f (LspId @'ServerToClient 'Method_ClientUnregisterCapability)
-> f ()
forall a b. (a -> b) -> a -> b
$ SServerMethod @'Request 'Method_ClientUnregisterCapability
-> MessageParams
@'ServerToClient @'Request 'Method_ClientUnregisterCapability
-> (Either
(TResponseError
@'ServerToClient 'Method_ClientUnregisterCapability)
(MessageResult
@'ServerToClient @'Request 'Method_ClientUnregisterCapability)
-> f ())
-> f (LspId @'ServerToClient 'Method_ClientUnregisterCapability)
forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod @'Request m
-> MessageParams @'ServerToClient @'Request m
-> (Either
(TResponseError @'ServerToClient m)
(MessageResult @'ServerToClient @'Request m)
-> f ())
-> f (LspId @'ServerToClient m)
sendRequest SServerMethod @'Request 'Method_ClientUnregisterCapability
SMethod_ClientUnregisterCapability UnregistrationParams
MessageParams
@'ServerToClient @'Request 'Method_ClientUnregisterCapability
params ((Either
(TResponseError
@'ServerToClient 'Method_ClientUnregisterCapability)
(MessageResult
@'ServerToClient @'Request 'Method_ClientUnregisterCapability)
-> f ())
-> f (LspId @'ServerToClient 'Method_ClientUnregisterCapability))
-> (Either
(TResponseError
@'ServerToClient 'Method_ClientUnregisterCapability)
(MessageResult
@'ServerToClient @'Request 'Method_ClientUnregisterCapability)
-> f ())
-> f (LspId @'ServerToClient 'Method_ClientUnregisterCapability)
forall a b. (a -> b) -> a -> b
$ \Either
(TResponseError
@'ServerToClient 'Method_ClientUnregisterCapability)
(MessageResult
@'ServerToClient @'Request 'Method_ClientUnregisterCapability)
_res -> () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
publishDiagnostics :: MonadLsp config m => Int -> NormalizedUri -> Maybe L.Int32 -> DiagnosticsBySource -> m ()
publishDiagnostics :: forall config (m :: * -> *).
MonadLsp config m =>
Int -> NormalizedUri -> Maybe Int32 -> DiagnosticsBySource -> m ()
publishDiagnostics Int
maxDiagnosticCount NormalizedUri
uri Maybe Int32
version DiagnosticsBySource
diags = m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m ()) -> m ()) -> m (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ (LanguageContextState config -> TVar DiagnosticStore)
-> (DiagnosticStore -> (m (), DiagnosticStore)) -> m (m ())
forall config (m :: * -> *) s a.
MonadLsp config m =>
(LanguageContextState config -> TVar s) -> (s -> (a, s)) -> m a
stateState LanguageContextState config -> TVar DiagnosticStore
forall config. LanguageContextState config -> TVar DiagnosticStore
resDiagnostics ((DiagnosticStore -> (m (), DiagnosticStore)) -> m (m ()))
-> (DiagnosticStore -> (m (), DiagnosticStore)) -> m (m ())
forall a b. (a -> b) -> a -> b
$ \DiagnosticStore
oldDiags ->
let !newDiags :: DiagnosticStore
newDiags = DiagnosticStore
-> NormalizedUri
-> Maybe Int32
-> DiagnosticsBySource
-> DiagnosticStore
updateDiagnostics DiagnosticStore
oldDiags NormalizedUri
uri Maybe Int32
version DiagnosticsBySource
diags
mdp :: Maybe PublishDiagnosticsParams
mdp = Int
-> DiagnosticStore
-> NormalizedUri
-> Maybe PublishDiagnosticsParams
getDiagnosticParamsFor Int
maxDiagnosticCount DiagnosticStore
newDiags NormalizedUri
uri
act :: m ()
act = case Maybe PublishDiagnosticsParams
mdp of
Maybe PublishDiagnosticsParams
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just PublishDiagnosticsParams
params ->
FromServerMessage -> m ()
forall config (m :: * -> *).
MonadLsp config m =>
FromServerMessage -> m ()
sendToClient (FromServerMessage -> m ()) -> FromServerMessage -> m ()
forall a b. (a -> b) -> a -> b
$ TNotificationMessage
@'ServerToClient 'Method_TextDocumentPublishDiagnostics
-> FromServerMessage
forall (m :: Method 'ServerToClient 'Notification).
((TMessage @'ServerToClient @'Notification m :: *)
~ (TNotificationMessage @'ServerToClient m :: *)) =>
TNotificationMessage @'ServerToClient m -> FromServerMessage
L.fromServerNot (TNotificationMessage
@'ServerToClient 'Method_TextDocumentPublishDiagnostics
-> FromServerMessage)
-> TNotificationMessage
@'ServerToClient 'Method_TextDocumentPublishDiagnostics
-> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Text
-> SMethod
@'ServerToClient
@'Notification
'Method_TextDocumentPublishDiagnostics
-> MessageParams
@'ServerToClient
@'Notification
'Method_TextDocumentPublishDiagnostics
-> TNotificationMessage
@'ServerToClient 'Method_TextDocumentPublishDiagnostics
forall (f :: MessageDirection) (m :: Method f 'Notification).
Text
-> SMethod @f @'Notification m
-> MessageParams @f @'Notification m
-> TNotificationMessage @f m
L.TNotificationMessage Text
"2.0" SMethod
@'ServerToClient
@'Notification
'Method_TextDocumentPublishDiagnostics
L.SMethod_TextDocumentPublishDiagnostics PublishDiagnosticsParams
MessageParams
@'ServerToClient
@'Notification
'Method_TextDocumentPublishDiagnostics
params
in (m ()
act, DiagnosticStore
newDiags)
flushDiagnosticsBySource ::
MonadLsp config m =>
Int ->
Maybe Text ->
m ()
flushDiagnosticsBySource :: forall config (m :: * -> *).
MonadLsp config m =>
Int -> Maybe Text -> m ()
flushDiagnosticsBySource Int
maxDiagnosticCount Maybe Text
msource = m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m ()) -> m ()) -> m (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ (LanguageContextState config -> TVar DiagnosticStore)
-> (DiagnosticStore -> (m (), DiagnosticStore)) -> m (m ())
forall config (m :: * -> *) s a.
MonadLsp config m =>
(LanguageContextState config -> TVar s) -> (s -> (a, s)) -> m a
stateState LanguageContextState config -> TVar DiagnosticStore
forall config. LanguageContextState config -> TVar DiagnosticStore
resDiagnostics ((DiagnosticStore -> (m (), DiagnosticStore)) -> m (m ()))
-> (DiagnosticStore -> (m (), DiagnosticStore)) -> m (m ())
forall a b. (a -> b) -> a -> b
$ \DiagnosticStore
oldDiags ->
let !newDiags :: DiagnosticStore
newDiags = DiagnosticStore -> Maybe Text -> DiagnosticStore
flushBySource DiagnosticStore
oldDiags Maybe Text
msource
act :: m ()
act = [NormalizedUri] -> (NormalizedUri -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (DiagnosticStore -> [NormalizedUri]
forall k v. HashMap k v -> [k]
HM.keys DiagnosticStore
newDiags) ((NormalizedUri -> m ()) -> m ())
-> (NormalizedUri -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \NormalizedUri
uri -> do
let mdp :: Maybe PublishDiagnosticsParams
mdp = Int
-> DiagnosticStore
-> NormalizedUri
-> Maybe PublishDiagnosticsParams
getDiagnosticParamsFor Int
maxDiagnosticCount DiagnosticStore
newDiags NormalizedUri
uri
case Maybe PublishDiagnosticsParams
mdp of
Maybe PublishDiagnosticsParams
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just PublishDiagnosticsParams
params -> do
FromServerMessage -> m ()
forall config (m :: * -> *).
MonadLsp config m =>
FromServerMessage -> m ()
sendToClient (FromServerMessage -> m ()) -> FromServerMessage -> m ()
forall a b. (a -> b) -> a -> b
$ TNotificationMessage
@'ServerToClient 'Method_TextDocumentPublishDiagnostics
-> FromServerMessage
forall (m :: Method 'ServerToClient 'Notification).
((TMessage @'ServerToClient @'Notification m :: *)
~ (TNotificationMessage @'ServerToClient m :: *)) =>
TNotificationMessage @'ServerToClient m -> FromServerMessage
L.fromServerNot (TNotificationMessage
@'ServerToClient 'Method_TextDocumentPublishDiagnostics
-> FromServerMessage)
-> TNotificationMessage
@'ServerToClient 'Method_TextDocumentPublishDiagnostics
-> FromServerMessage
forall a b. (a -> b) -> a -> b
$ Text
-> SMethod
@'ServerToClient
@'Notification
'Method_TextDocumentPublishDiagnostics
-> MessageParams
@'ServerToClient
@'Notification
'Method_TextDocumentPublishDiagnostics
-> TNotificationMessage
@'ServerToClient 'Method_TextDocumentPublishDiagnostics
forall (f :: MessageDirection) (m :: Method f 'Notification).
Text
-> SMethod @f @'Notification m
-> MessageParams @f @'Notification m
-> TNotificationMessage @f m
L.TNotificationMessage Text
"2.0" SMethod
@'ServerToClient
@'Notification
'Method_TextDocumentPublishDiagnostics
L.SMethod_TextDocumentPublishDiagnostics PublishDiagnosticsParams
MessageParams
@'ServerToClient
@'Notification
'Method_TextDocumentPublishDiagnostics
params
in (m ()
act, DiagnosticStore
newDiags)
reverseSortEdit :: L.WorkspaceEdit -> L.WorkspaceEdit
reverseSortEdit :: WorkspaceEdit -> WorkspaceEdit
reverseSortEdit (L.WorkspaceEdit Maybe (Map Uri [TextEdit])
cs Maybe
[TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
dcs Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
anns) = Maybe (Map Uri [TextEdit])
-> Maybe
[TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
-> WorkspaceEdit
L.WorkspaceEdit Maybe (Map Uri [TextEdit])
cs' Maybe
[TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
dcs' Maybe (Map ChangeAnnotationIdentifier ChangeAnnotation)
anns
where
cs' :: Maybe (Map.Map Uri [TextEdit])
cs' :: Maybe (Map Uri [TextEdit])
cs' = ((Map Uri [TextEdit] -> Map Uri [TextEdit])
-> Maybe (Map Uri [TextEdit]) -> Maybe (Map Uri [TextEdit])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Map Uri [TextEdit] -> Map Uri [TextEdit])
-> Maybe (Map Uri [TextEdit]) -> Maybe (Map Uri [TextEdit]))
-> (([TextEdit] -> [TextEdit])
-> Map Uri [TextEdit] -> Map Uri [TextEdit])
-> ([TextEdit] -> [TextEdit])
-> Maybe (Map Uri [TextEdit])
-> Maybe (Map Uri [TextEdit])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TextEdit] -> [TextEdit])
-> Map Uri [TextEdit] -> Map Uri [TextEdit]
forall a b. (a -> b) -> Map Uri a -> Map Uri b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) [TextEdit] -> [TextEdit]
sortTextEdits Maybe (Map Uri [TextEdit])
cs
dcs' :: Maybe [L.DocumentChange]
dcs' :: Maybe
[TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
dcs' = (([TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> [TextDocumentEdit
|? (CreateFile |? (RenameFile |? DeleteFile))])
-> Maybe
[TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe
[TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> [TextDocumentEdit
|? (CreateFile |? (RenameFile |? DeleteFile))])
-> Maybe
[TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe
[TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))])
-> (((TextDocumentEdit
|? (CreateFile |? (RenameFile |? DeleteFile)))
-> TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile)))
-> [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> [TextDocumentEdit
|? (CreateFile |? (RenameFile |? DeleteFile))])
-> ((TextDocumentEdit
|? (CreateFile |? (RenameFile |? DeleteFile)))
-> TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile)))
-> Maybe
[TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> Maybe
[TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile)))
-> TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile)))
-> [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
-> [TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile)))
-> TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))
sortOnlyTextDocumentEdits Maybe
[TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))]
dcs
sortTextEdits :: [L.TextEdit] -> [L.TextEdit]
sortTextEdits :: [TextEdit] -> [TextEdit]
sortTextEdits [TextEdit]
edits = (TextEdit -> Down Range) -> [TextEdit] -> [TextEdit]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (Range -> Down Range
forall a. a -> Down a
Down (Range -> Down Range)
-> (TextEdit -> Range) -> TextEdit -> Down Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextEdit -> Getting Range TextEdit Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range TextEdit Range
forall s a. HasRange s a => Lens' s a
Lens' TextEdit Range
L.range)) [TextEdit]
edits
sortOnlyTextDocumentEdits :: L.DocumentChange -> L.DocumentChange
sortOnlyTextDocumentEdits :: (TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile)))
-> TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))
sortOnlyTextDocumentEdits (L.InL (L.TextDocumentEdit OptionalVersionedTextDocumentIdentifier
td [TextEdit |? AnnotatedTextEdit]
edits)) = TextDocumentEdit
-> TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))
forall a b. a -> a |? b
L.InL (TextDocumentEdit
-> TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile)))
-> TextDocumentEdit
-> TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))
forall a b. (a -> b) -> a -> b
$ OptionalVersionedTextDocumentIdentifier
-> [TextEdit |? AnnotatedTextEdit] -> TextDocumentEdit
L.TextDocumentEdit OptionalVersionedTextDocumentIdentifier
td [TextEdit |? AnnotatedTextEdit]
edits'
where
edits' :: [TextEdit |? AnnotatedTextEdit]
edits' = ((TextEdit |? AnnotatedTextEdit) -> Down Range)
-> [TextEdit |? AnnotatedTextEdit]
-> [TextEdit |? AnnotatedTextEdit]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (Range -> Down Range
forall a. a -> Down a
Down (Range -> Down Range)
-> ((TextEdit |? AnnotatedTextEdit) -> Range)
-> (TextEdit |? AnnotatedTextEdit)
-> Down Range
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextEdit |? AnnotatedTextEdit) -> Range
editRange) [TextEdit |? AnnotatedTextEdit]
edits
sortOnlyTextDocumentEdits (L.InR CreateFile |? (RenameFile |? DeleteFile)
others) = (CreateFile |? (RenameFile |? DeleteFile))
-> TextDocumentEdit |? (CreateFile |? (RenameFile |? DeleteFile))
forall a b. b -> a |? b
L.InR CreateFile |? (RenameFile |? DeleteFile)
others
editRange :: L.TextEdit L.|? L.AnnotatedTextEdit -> L.Range
editRange :: (TextEdit |? AnnotatedTextEdit) -> Range
editRange (L.InR AnnotatedTextEdit
e) = AnnotatedTextEdit
e AnnotatedTextEdit -> Getting Range AnnotatedTextEdit Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range AnnotatedTextEdit Range
forall s a. HasRange s a => Lens' s a
Lens' AnnotatedTextEdit Range
L.range
editRange (L.InL TextEdit
e) = TextEdit
e TextEdit -> Getting Range TextEdit Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range TextEdit Range
forall s a. HasRange s a => Lens' s a
Lens' TextEdit Range
L.range
tryChangeConfig :: (m ~ LspM config) => LogAction m (WithSeverity LspCoreLog) -> J.Value -> m ()
tryChangeConfig :: forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspCoreLog) -> Value -> m ()
tryChangeConfig LogAction m (WithSeverity LspCoreLog)
logger Value
newConfigObject = do
config -> Value -> Either Text config
parseCfg <- ReaderT
(LanguageContextEnv config)
IO
(config -> Value -> Either Text config)
-> LspT config IO (config -> Value -> Either Text config)
forall config (m :: * -> *) a.
ReaderT (LanguageContextEnv config) m a -> LspT config m a
LspT (ReaderT
(LanguageContextEnv config)
IO
(config -> Value -> Either Text config)
-> LspT config IO (config -> Value -> Either Text config))
-> ReaderT
(LanguageContextEnv config)
IO
(config -> Value -> Either Text config)
-> LspT config IO (config -> Value -> Either Text config)
forall a b. (a -> b) -> a -> b
$ (LanguageContextEnv config
-> config -> Value -> Either Text config)
-> ReaderT
(LanguageContextEnv config)
IO
(config -> Value -> Either Text config)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks LanguageContextEnv config -> config -> Value -> Either Text config
forall config.
LanguageContextEnv config -> config -> Value -> Either Text config
resParseConfig
Either Text config
res <- (LanguageContextState config -> TVar config)
-> (config -> (Either Text config, config))
-> m (Either Text config)
forall config (m :: * -> *) s a.
MonadLsp config m =>
(LanguageContextState config -> TVar s) -> (s -> (a, s)) -> m a
stateState LanguageContextState config -> TVar config
forall config. LanguageContextState config -> TVar config
resConfig ((config -> (Either Text config, config))
-> m (Either Text config))
-> (config -> (Either Text config, config))
-> m (Either Text config)
forall a b. (a -> b) -> a -> b
$ \config
oldConfig -> case config -> Value -> Either Text config
parseCfg config
oldConfig Value
newConfigObject of
Left Text
err -> (Text -> Either Text config
forall a b. a -> Either a b
Left Text
err, config
oldConfig)
Right config
newConfig -> (config -> Either Text config
forall a b. b -> Either a b
Right config
newConfig, config
newConfig)
case Either Text config
res of
Left Text
err -> do
LogAction m (WithSeverity LspCoreLog)
logger LogAction m (WithSeverity LspCoreLog)
-> WithSeverity LspCoreLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Value -> Text -> LspCoreLog
ConfigurationParseError Value
newConfigObject Text
err LspCoreLog -> Severity -> WithSeverity LspCoreLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Warning
Right config
newConfig -> do
LogAction m (WithSeverity LspCoreLog)
logger LogAction m (WithSeverity LspCoreLog)
-> WithSeverity LspCoreLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Value -> LspCoreLog
NewConfig Value
newConfigObject LspCoreLog -> Severity -> WithSeverity LspCoreLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
config -> IO ()
cb <- ReaderT (LanguageContextEnv config) IO (config -> IO ())
-> LspT config IO (config -> IO ())
forall config (m :: * -> *) a.
ReaderT (LanguageContextEnv config) m a -> LspT config m a
LspT (ReaderT (LanguageContextEnv config) IO (config -> IO ())
-> LspT config IO (config -> IO ()))
-> ReaderT (LanguageContextEnv config) IO (config -> IO ())
-> LspT config IO (config -> IO ())
forall a b. (a -> b) -> a -> b
$ (LanguageContextEnv config -> config -> IO ())
-> ReaderT (LanguageContextEnv config) IO (config -> IO ())
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks LanguageContextEnv config -> config -> IO ()
forall config. LanguageContextEnv config -> config -> IO ()
resOnConfigChange
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ config -> IO ()
cb config
newConfig
requestConfigUpdate :: (m ~ LspM config) => LogAction m (WithSeverity LspCoreLog) -> m ()
requestConfigUpdate :: forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspCoreLog) -> m ()
requestConfigUpdate LogAction m (WithSeverity LspCoreLog)
logger = do
ClientCapabilities
caps <- ReaderT (LanguageContextEnv config) IO ClientCapabilities
-> LspT config IO ClientCapabilities
forall config (m :: * -> *) a.
ReaderT (LanguageContextEnv config) m a -> LspT config m a
LspT (ReaderT (LanguageContextEnv config) IO ClientCapabilities
-> LspT config IO ClientCapabilities)
-> ReaderT (LanguageContextEnv config) IO ClientCapabilities
-> LspT config IO ClientCapabilities
forall a b. (a -> b) -> a -> b
$ (LanguageContextEnv config -> ClientCapabilities)
-> ReaderT (LanguageContextEnv config) IO ClientCapabilities
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks LanguageContextEnv config -> ClientCapabilities
forall config. LanguageContextEnv config -> ClientCapabilities
resClientCapabilities
let supportsConfiguration :: Bool
supportsConfiguration = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ClientCapabilities
caps ClientCapabilities
-> Getting (First Bool) ClientCapabilities Bool -> Maybe Bool
forall s a. s -> Getting (First a) s a -> Maybe a
^? (Maybe WorkspaceClientCapabilities
-> Const @(*) (First Bool) (Maybe WorkspaceClientCapabilities))
-> ClientCapabilities -> Const @(*) (First Bool) ClientCapabilities
forall s a. HasWorkspace s a => Lens' s a
Lens' ClientCapabilities (Maybe WorkspaceClientCapabilities)
L.workspace ((Maybe WorkspaceClientCapabilities
-> Const @(*) (First Bool) (Maybe WorkspaceClientCapabilities))
-> ClientCapabilities
-> Const @(*) (First Bool) ClientCapabilities)
-> ((Bool -> Const @(*) (First Bool) Bool)
-> Maybe WorkspaceClientCapabilities
-> Const @(*) (First Bool) (Maybe WorkspaceClientCapabilities))
-> Getting (First Bool) ClientCapabilities Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WorkspaceClientCapabilities
-> Const @(*) (First Bool) WorkspaceClientCapabilities)
-> Maybe WorkspaceClientCapabilities
-> Const @(*) (First Bool) (Maybe WorkspaceClientCapabilities)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((WorkspaceClientCapabilities
-> Const @(*) (First Bool) WorkspaceClientCapabilities)
-> Maybe WorkspaceClientCapabilities
-> Const @(*) (First Bool) (Maybe WorkspaceClientCapabilities))
-> ((Bool -> Const @(*) (First Bool) Bool)
-> WorkspaceClientCapabilities
-> Const @(*) (First Bool) WorkspaceClientCapabilities)
-> (Bool -> Const @(*) (First Bool) Bool)
-> Maybe WorkspaceClientCapabilities
-> Const @(*) (First Bool) (Maybe WorkspaceClientCapabilities)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Const @(*) (First Bool) (Maybe Bool))
-> WorkspaceClientCapabilities
-> Const @(*) (First Bool) WorkspaceClientCapabilities
forall s a. HasConfiguration s a => Lens' s a
Lens' WorkspaceClientCapabilities (Maybe Bool)
L.configuration ((Maybe Bool -> Const @(*) (First Bool) (Maybe Bool))
-> WorkspaceClientCapabilities
-> Const @(*) (First Bool) WorkspaceClientCapabilities)
-> ((Bool -> Const @(*) (First Bool) Bool)
-> Maybe Bool -> Const @(*) (First Bool) (Maybe Bool))
-> (Bool -> Const @(*) (First Bool) Bool)
-> WorkspaceClientCapabilities
-> Const @(*) (First Bool) WorkspaceClientCapabilities
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Const @(*) (First Bool) Bool)
-> Maybe Bool -> Const @(*) (First Bool) (Maybe Bool)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just
if Bool
supportsConfiguration
then do
Text
section <- ReaderT (LanguageContextEnv config) IO Text -> LspT config IO Text
forall config (m :: * -> *) a.
ReaderT (LanguageContextEnv config) m a -> LspT config m a
LspT (ReaderT (LanguageContextEnv config) IO Text
-> LspT config IO Text)
-> ReaderT (LanguageContextEnv config) IO Text
-> LspT config IO Text
forall a b. (a -> b) -> a -> b
$ (LanguageContextEnv config -> Text)
-> ReaderT (LanguageContextEnv config) IO Text
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks LanguageContextEnv config -> Text
forall config. LanguageContextEnv config -> Text
resConfigSection
m (LspId @'ServerToClient 'Method_WorkspaceConfiguration) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (LspId @'ServerToClient 'Method_WorkspaceConfiguration) -> m ())
-> m (LspId @'ServerToClient 'Method_WorkspaceConfiguration)
-> m ()
forall a b. (a -> b) -> a -> b
$ SServerMethod @'Request 'Method_WorkspaceConfiguration
-> MessageParams
@'ServerToClient @'Request 'Method_WorkspaceConfiguration
-> (Either
(TResponseError @'ServerToClient 'Method_WorkspaceConfiguration)
(MessageResult
@'ServerToClient @'Request 'Method_WorkspaceConfiguration)
-> m ())
-> m (LspId @'ServerToClient 'Method_WorkspaceConfiguration)
forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod @'Request m
-> MessageParams @'ServerToClient @'Request m
-> (Either
(TResponseError @'ServerToClient m)
(MessageResult @'ServerToClient @'Request m)
-> f ())
-> f (LspId @'ServerToClient m)
sendRequest SServerMethod @'Request 'Method_WorkspaceConfiguration
SMethod_WorkspaceConfiguration ([ConfigurationItem] -> ConfigurationParams
ConfigurationParams [Maybe Uri -> Maybe Text -> ConfigurationItem
ConfigurationItem Maybe Uri
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
section)]) ((Either
(TResponseError @'ServerToClient 'Method_WorkspaceConfiguration)
(MessageResult
@'ServerToClient @'Request 'Method_WorkspaceConfiguration)
-> m ())
-> m (LspId @'ServerToClient 'Method_WorkspaceConfiguration))
-> (Either
(TResponseError @'ServerToClient 'Method_WorkspaceConfiguration)
(MessageResult
@'ServerToClient @'Request 'Method_WorkspaceConfiguration)
-> m ())
-> m (LspId @'ServerToClient 'Method_WorkspaceConfiguration)
forall a b. (a -> b) -> a -> b
$ \case
Right [Value
newConfigObject] -> LogAction m (WithSeverity LspCoreLog) -> Value -> m ()
forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
LogAction m (WithSeverity LspCoreLog) -> Value -> m ()
tryChangeConfig LogAction m (WithSeverity LspCoreLog)
logger Value
newConfigObject
Right MessageResult
@'ServerToClient @'Request 'Method_WorkspaceConfiguration
sections -> LogAction m (WithSeverity LspCoreLog)
logger LogAction m (WithSeverity LspCoreLog)
-> WithSeverity LspCoreLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& [Value] -> LspCoreLog
WrongConfigSections [Value]
MessageResult
@'ServerToClient @'Request 'Method_WorkspaceConfiguration
sections LspCoreLog -> Severity -> WithSeverity LspCoreLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Error
Left TResponseError @'ServerToClient 'Method_WorkspaceConfiguration
err -> LogAction m (WithSeverity LspCoreLog)
logger LogAction m (WithSeverity LspCoreLog)
-> WithSeverity LspCoreLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& TResponseError @'ServerToClient 'Method_WorkspaceConfiguration
-> LspCoreLog
BadConfigurationResponse TResponseError @'ServerToClient 'Method_WorkspaceConfiguration
err LspCoreLog -> Severity -> WithSeverity LspCoreLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Error
else LogAction m (WithSeverity LspCoreLog)
logger LogAction m (WithSeverity LspCoreLog)
-> WithSeverity LspCoreLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& LspCoreLog
ConfigurationNotSupported LspCoreLog -> Severity -> WithSeverity LspCoreLog
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
isShuttingDown :: (m ~ LspM config) => m Bool
isShuttingDown :: forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
m Bool
isShuttingDown = do
Barrier ()
b <- LanguageContextState config -> Barrier ()
forall config. LanguageContextState config -> Barrier ()
resShutdown (LanguageContextState config -> Barrier ())
-> (LanguageContextEnv config -> LanguageContextState config)
-> LanguageContextEnv config
-> Barrier ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextEnv config -> LanguageContextState config
forall config.
LanguageContextEnv config -> LanguageContextState config
resState (LanguageContextEnv config -> Barrier ())
-> m (LanguageContextEnv config) -> m (Barrier ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (LanguageContextEnv config)
forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
getLspEnv
Maybe ()
r <- IO (Maybe ()) -> m (Maybe ())
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ()) -> m (Maybe ())) -> IO (Maybe ()) -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ Barrier () -> IO (Maybe ())
forall a. Barrier a -> IO (Maybe a)
C.waitBarrierMaybe Barrier ()
b
Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ case Maybe ()
r of
Just ()
_ -> Bool
True
Maybe ()
Nothing -> Bool
False
waitShuttingDown :: (m ~ LspM config) => m ()
waitShuttingDown :: forall (m :: * -> *) config.
((m :: (* -> *)) ~ (LspM config :: (* -> *))) =>
m ()
waitShuttingDown = do
Barrier ()
b <- LanguageContextState config -> Barrier ()
forall config. LanguageContextState config -> Barrier ()
resShutdown (LanguageContextState config -> Barrier ())
-> (LanguageContextEnv config -> LanguageContextState config)
-> LanguageContextEnv config
-> Barrier ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextEnv config -> LanguageContextState config
forall config.
LanguageContextEnv config -> LanguageContextState config
resState (LanguageContextEnv config -> Barrier ())
-> m (LanguageContextEnv config) -> m (Barrier ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (LanguageContextEnv config)
forall config (m :: * -> *).
MonadLsp config m =>
m (LanguageContextEnv config)
getLspEnv
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Barrier () -> IO ()
forall a. Barrier a -> IO a
C.waitBarrier Barrier ()
b