{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeInType #-}
{-# 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.Applicative
import Control.Concurrent.Async
import Control.Concurrent.MVar
import Control.Concurrent.STM
import Control.Exception qualified as E
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.Row
import Data.Text (Text)
import Data.Text qualified as T
import Data.UUID qualified as UUID
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
import System.Random hiding (next)

-- ---------------------------------------------------------------------
{-# ANN module ("HLint: ignore Eta reduce" :: String) #-}
{-# ANN module ("HLint: ignore Redundant do" :: String) #-}
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}

-- ---------------------------------------------------------------------

data LspCoreLog
  = -- TODO: arguably it would be nicer to have the config object itself in there, but
    -- then we're going to need 'Pretty config' constraints everywhere
    NewConfig J.Value
  | ConfigurationParseError J.Value T.Text
  | ConfigurationNotSupported
  | BadConfigurationResponse ResponseError
  | 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 ResponseError
err) = Doc ann
"LSP: error when requesting configuration: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ResponseError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. ResponseError -> Doc ann
pretty ResponseError
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 -> Doc ann) -> Value -> Doc ann
forall a b. (a -> b) -> a -> b
$ [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)

-- for deriving the instance of MonadUnliftIO
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 ())
  , -- We keep the state in a TVar to be thread safe
    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)
  }

-- ---------------------------------------------------------------------
-- Handlers
-- ---------------------------------------------------------------------

{- | A mapping from methods to the static 'Handler's that should be used to
 handle responses when they come in from the client. To build up a 'Handlers',
 you should 'mconcat' a list of 'notificationHandler' and 'requestHandler's:

 @
 mconcat [
   notificationHandler SInitialized $ \notif -> pure ()
 , requestHandler STextDocumentHover $ \req responder -> pure ()
 ]
 @
-}
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

-- | Wrapper to restrict 'Handler's to  ClientToServer' 'Method's
newtype ClientMessageHandler f (t :: MessageKind) (m :: Method ClientToServer t) = ClientMessageHandler (Handler f m)

{- | The type of a handler that handles requests and notifications coming in
 from the server or client
-}
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 ResponseError (MessageResult m) -> f ()) -> f ()
  Handler f (m :: Method _from Notification) = TNotificationMessage m -> f ()

-- | How to convert two isomorphic data structures between each other.
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 ResponseError (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
      ResponseError (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
      ResponseError (MessageResult @'ClientToServer @'Request a)
    -> n ())
-> Either
     ResponseError (MessageResult @'ClientToServer @'Request a)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ResponseError (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

-- | state used by the LSP dispatcher to manage the message loop
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)
  }

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
sel (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
  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
sel (LanguageContextState config -> TVar s)
-> (LanguageContextEnv config -> LanguageContextState config)
-> LanguageContextEnv config
-> TVar s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextEnv config -> LanguageContextState config
forall config.
LanguageContextEnv config -> LanguageContextState config
resState (LanguageContextEnv config -> TVar s)
-> m (LanguageContextEnv config) -> m (TVar s)
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 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
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
  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

-- ---------------------------------------------------------------------

{- | Language Server Protocol options that the server may configure.
 If you set handlers for some requests, you may need to set some of these options.
-}
data Options = Options
  { Options -> Maybe TextDocumentSyncOptions
optTextDocumentSync :: Maybe L.TextDocumentSyncOptions
  , Options -> Maybe String
optCompletionTriggerCharacters :: Maybe [Char]
  -- ^  The characters that trigger completion automatically.
  , Options -> Maybe String
optCompletionAllCommitCharacters :: Maybe [Char]
  -- ^ The list of all possible characters that commit a completion. This field can be used
  -- if clients don't support individual commit characters per completion item. See
  -- `_commitCharactersSupport`.
  , Options -> Maybe String
optSignatureHelpTriggerCharacters :: Maybe [Char]
  -- ^ The characters that trigger signature help automatically.
  , Options -> Maybe String
optSignatureHelpRetriggerCharacters :: Maybe [Char]
  -- ^ List of characters that re-trigger signature help.
  -- These trigger characters are only active when signature help is already showing. All trigger characters
  -- are also counted as re-trigger characters.
  , Options -> Maybe [CodeActionKind]
optCodeActionKinds :: Maybe [CodeActionKind]
  -- ^ CodeActionKinds that this server may return.
  -- The list of kinds may be generic, such as `CodeActionKind.Refactor`, or the server
  -- may list out every specific kind they provide.
  , Options -> Maybe (NonEmpty Char)
optDocumentOnTypeFormattingTriggerCharacters :: Maybe (NonEmpty Char)
  -- ^ The list of characters that triggers on type formatting.
  -- If you set `documentOnTypeFormattingHandler`, you **must** set this.
  -- The first character is mandatory, so a 'NonEmpty' should be passed.
  , Options -> Maybe [Text]
optExecuteCommandCommands :: Maybe [Text]
  -- ^ The commands to be executed on the server.
  -- If you set `executeCommandHandler`, you **must** set this.
  , Options
-> Maybe
     (Rec
        ((.+)
           @(*) ((.==) @(*) "name" Text) ((.==) @(*) "version" (Maybe Text))))
optServerInfo :: Maybe (Rec ("name" .== Text .+ "version" .== Maybe Text))
  -- ^ Information about the server that can be advertised to the client.
  , Options -> Bool
optSupportClientInitiatedProgress :: Bool
  -- ^ Whether or not to support client-initiated progress.
  }

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
     (Rec
        ((.+)
           @(*) ((.==) @(*) "name" Text) ((.==) @(*) "version" (Maybe Text))))
-> Bool
-> 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
  (Rec
     ((.+)
        @(*) ((.==) @(*) "name" Text) ((.==) @(*) "version" (Maybe Text))))
Maybe
  (Rec
     ('R
        @(*)
        ((':)
           @(LT (*))
           ((':->) @(*) "name" Text)
           ((':)
              @(LT (*)) ((':->) @(*) "version" (Maybe Text)) ('[] @(LT (*)))))))
forall a. Maybe a
Nothing
      Bool
False

defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options
forall a. Default a => a
def

{- | A package indicating the percentage of progress complete and a
 an optional message to go with it during a 'withProgress'

 @since 0.10.0.0
-}
data ProgressAmount = ProgressAmount (Maybe UInt) (Maybe Text)

{- | Thrown if the user cancels a 'Cancellable' 'withProgress'/'withIndefiniteProgress'/ session

 @since 0.11.0.0
-}
data ProgressCancelledException = ProgressCancelledException
  deriving (Int -> ProgressCancelledException -> ShowS
[ProgressCancelledException] -> ShowS
ProgressCancelledException -> String
(Int -> ProgressCancelledException -> ShowS)
-> (ProgressCancelledException -> String)
-> ([ProgressCancelledException] -> ShowS)
-> Show ProgressCancelledException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProgressCancelledException -> ShowS
showsPrec :: Int -> ProgressCancelledException -> ShowS
$cshow :: ProgressCancelledException -> String
show :: ProgressCancelledException -> String
$cshowList :: [ProgressCancelledException] -> ShowS
showList :: [ProgressCancelledException] -> ShowS
Show)

instance E.Exception ProgressCancelledException

{- | Whether or not the user should be able to cancel a 'withProgress'/'withIndefiniteProgress'
 session

 @since 0.11.0.0
-}
data ProgressCancellable = Cancellable | NotCancellable

-- See Note [LSP configuration] for discussion of the configuration-related fields

{- | Contains all the callbacks to use for initialized the language server.
 it is parameterized over a config type variable representing the type for the
 specific configuration data the language server needs to use.
-}
data ServerDefinition config = forall m a.
  ServerDefinition
  { forall config. ServerDefinition config -> config
defaultConfig :: config
  -- ^ The default value we initialize the config variable to.
  , forall config. ServerDefinition config -> Text
configSection :: T.Text
  -- ^ The "config section" that this server uses. This is used to identify the settings
  -- that are relevant to the server.
  , forall config.
ServerDefinition config -> config -> Value -> Either Text config
parseConfig :: config -> J.Value -> Either T.Text config
  -- ^ @parseConfig oldConfig newConfigObject@ is called whenever we
  -- get updated configuration from the client.
  --
  -- @parseConfig@ is called on the object corresponding to the server's
  -- config section, it should not itself try to look for the config section.
  --
  -- Note that the 'J.Value' may represent only a partial object in the case where we
  -- are handling a @workspace/didChangeConfiguration@ request where the client sends
  -- only the changed settings. This is also the main circumstance where the old configuration
  -- argument is useful. It is generally fine for servers to ignore this case and just
  -- assume that the 'J.Value' represents a full new config and ignore the old configuration.
  -- This will only be problematic in the case of clients which behave as above and *also*
  -- don't support @workspace/configuration@, which is discouraged.
  , ()
onConfigChange :: config -> m ()
  -- ^ This callback is called any time the configuration is updated, with
  -- the new config. Servers that want to react to config changes should provide
  -- a callback here, it is not sufficient to just add e.g. a @workspace/didChangeConfiguration@
  -- handler.
  , ()
doInitialize :: LanguageContextEnv config -> TMessage Method_Initialize -> IO (Either ResponseError a)
  -- ^ Called *after* receiving the @initialize@ request and *before*
  -- returning the response. This callback will be invoked to offer the
  -- language server implementation the chance to create any processes or
  -- start new threads that may be necessary for the server lifecycle. It can
  -- also return an error in the initialization if necessary.
  , ()
staticHandlers :: ClientCapabilities -> Handlers m
  -- ^ Handlers for any methods you want to statically support.
  -- The handlers here cannot be unregistered during the server's lifetime
  -- and will be registered statically in the initialize request.
  -- The handlers provided can depend on the client capabilities, which
  -- are static across the lifetime of the server.
  , ()
interpretHandler :: a -> (m <~> IO)
  -- ^ How to run the handlers in your own monad of choice, @m@.
  -- It is passed the result of 'doInitialize', so typically you will want
  -- to thread along the 'LanguageContextEnv' as well as any other state you
  -- need to run your monad. @m@ should most likely be built on top of
  -- 'LspT'.
  --
  -- @
  --  ServerDefinition { ...
  --  , doInitialize = \env _req -> pure $ Right env
  --  , interpretHandler = \env -> Iso
  --     (runLspT env) -- how to convert from IO ~> m
  --     liftIO        -- how to convert from m ~> IO
  --  }
  -- @
  , forall config. ServerDefinition config -> Options
options :: Options
  -- ^ Configurable options for the server's capabilities.
  }

{- | A function that a 'Handler' is passed that can be used to respond to a
 request with either an error, or the response params.
-}
newtype ServerResponseCallback (m :: Method ServerToClient Request)
  = ServerResponseCallback (Either ResponseError (MessageResult m) -> IO ())

{- | Return value signals if response handler was inserted successfully
 Might fail if the id was already in the map
-}
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 ResponseError (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
      ResponseError (MessageResult @'ServerToClient @'Request m)
    -> f ())
-> f (LspId @'ServerToClient m)
sendRequest SServerMethod @'Request m
m MessageParams @'ServerToClient @'Request m
params Either ResponseError (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 ResponseError (MessageResult @'ServerToClient @'Request m)
 -> IO ())
-> ServerResponseCallback m
forall (m :: Method 'ServerToClient 'Request).
(Either ResponseError (MessageResult @'ServerToClient @'Request m)
 -> IO ())
-> ServerResponseCallback m
ServerResponseCallback (f () -> IO ()
rio (f () -> IO ())
-> (Either
      ResponseError (MessageResult @'ServerToClient @'Request m)
    -> f ())
-> Either
     ResponseError (MessageResult @'ServerToClient @'Request m)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ResponseError (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

-- ---------------------------------------------------------------------

-- | Return the 'VirtualFile' associated with a given 'NormalizedUri', if there is one.
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 #-}

-- | Take an atomic snapshot of the current state of the virtual file system.
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 #-}

{- | Dump the current text for a given VFS file to a file
 in the given directory and return the path to the file.
-}
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
              -- TODO: Does the VFS make sense for URIs which are not files?
              -- The reverse map should perhaps be (FilePath -> URI)
              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')

-- | Given a text document identifier, annotate it with the latest version.
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 #-}

-- TODO: should this function return a URI?

{- | If the contents of a VFS has been dumped to a temporary file, map
 the temporary file name back to the original one.
-}
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 -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
fp (Maybe String -> String)
-> (VFSData -> Maybe String) -> VFSData -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
fp (Map String String -> Maybe String)
-> (VFSData -> Map String String) -> VFSData -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VFSData -> Map String String
reverseMap (VFSData -> String) -> VFSData -> String
forall a b. (a -> b) -> a -> b
$ 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 #-}

-- ---------------------------------------------------------------------

{- | The current configuration from the client as set via the @initialize@ and
 @workspace/didChangeConfiguration@ requests, as well as by calls to
 'setConfig'.
-}
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 #-}

-- | The current workspace folders, if the client supports workspace folders.
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 #-}

{- | Sends a @client/registerCapability@ request and dynamically registers
 a 'Method' with a 'Handler'. Returns 'Nothing' if the client does not
 support dynamic registration for the specified method, otherwise a
 'RegistrationToken' which can be used to unregister it later.
-}
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
  -- If the server has already registered statically, don't dynamically register
  -- as per the spec
  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 ResponseError (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
      ResponseError (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
      ResponseError (MessageResult @'ClientToServer @'Request m)
    -> IO ())
-> Either
     ResponseError (MessageResult @'ClientToServer @'Request m)
-> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ResponseError (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
  -- First, check to see if the client supports dynamic registration on this method
  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
uuid <- IO Text -> f Text
forall a. IO a -> f a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> f Text) -> IO Text -> f Text
forall a b. (a -> b) -> a -> b
$ UUID -> Text
UUID.toText (UUID -> Text) -> IO UUID -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StdGen -> (UUID, StdGen)) -> IO UUID
forall (m :: * -> *) a. MonadIO m => (StdGen -> (a, StdGen)) -> m a
getStdRandom StdGen -> (UUID, StdGen)
forall g. RandomGen g => g -> (UUID, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random
      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
uuid 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
uuid

      -- TODO: handle the scenario where this returns an error
      LspId @'ServerToClient 'Method_ClientRegisterCapability
_ <- SServerMethod @'Request 'Method_ClientRegisterCapability
-> MessageParams
     @'ServerToClient @'Request 'Method_ClientRegisterCapability
-> (Either
      ResponseError
      (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
      ResponseError (MessageResult @'ServerToClient @'Request m)
    -> f ())
-> f (LspId @'ServerToClient m)
sendRequest SServerMethod @'Request 'Method_ClientRegisterCapability
SMethod_ClientRegisterCapability RegistrationParams
MessageParams
  @'ServerToClient @'Request 'Method_ClientRegisterCapability
params ((Either
    ResponseError
    (MessageResult
       @'ServerToClient @'Request 'Method_ClientRegisterCapability)
  -> f ())
 -> f (LspId @'ServerToClient 'Method_ClientRegisterCapability))
-> (Either
      ResponseError
      (MessageResult
         @'ServerToClient @'Request 'Method_ClientRegisterCapability)
    -> f ())
-> f (LspId @'ServerToClient 'Method_ClientRegisterCapability)
forall a b. (a -> b) -> a -> b
$ \Either
  ResponseError
  (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

{- | Sends a @client/unregisterCapability@ request and removes the handler
 for that associated registration.
-}
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
      ResponseError
      (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
      ResponseError (MessageResult @'ServerToClient @'Request m)
    -> f ())
-> f (LspId @'ServerToClient m)
sendRequest SServerMethod @'Request 'Method_ClientUnregisterCapability
SMethod_ClientUnregisterCapability UnregistrationParams
MessageParams
  @'ServerToClient @'Request 'Method_ClientUnregisterCapability
params ((Either
    ResponseError
    (MessageResult
       @'ServerToClient @'Request 'Method_ClientUnregisterCapability)
  -> f ())
 -> f (LspId @'ServerToClient 'Method_ClientUnregisterCapability))
-> (Either
      ResponseError
      (MessageResult
         @'ServerToClient @'Request 'Method_ClientUnregisterCapability)
    -> f ())
-> f (LspId @'ServerToClient 'Method_ClientUnregisterCapability)
forall a b. (a -> b) -> a -> b
$ \Either
  ResponseError
  (MessageResult
     @'ServerToClient @'Request 'Method_ClientUnregisterCapability)
_res -> () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

--------------------------------------------------------------------------------
-- PROGRESS
--------------------------------------------------------------------------------

storeProgress :: MonadLsp config m => ProgressToken -> Async a -> m ()
storeProgress :: forall config (m :: * -> *) a.
MonadLsp config m =>
ProgressToken -> Async a -> m ()
storeProgress ProgressToken
n Async a
a = (LanguageContextState config -> TVar (Map ProgressToken (IO ())))
-> (Map ProgressToken (IO ()) -> Map ProgressToken (IO ())) -> m ()
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> (a -> a) -> m ()
modifyState (ProgressData -> TVar (Map ProgressToken (IO ()))
progressCancel (ProgressData -> TVar (Map ProgressToken (IO ())))
-> (LanguageContextState config -> ProgressData)
-> LanguageContextState config
-> TVar (Map ProgressToken (IO ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextState config -> ProgressData
forall config. LanguageContextState config -> ProgressData
resProgressData) ((Map ProgressToken (IO ()) -> Map ProgressToken (IO ())) -> m ())
-> (Map ProgressToken (IO ()) -> Map ProgressToken (IO ())) -> m ()
forall a b. (a -> b) -> a -> b
$ ProgressToken
-> IO () -> Map ProgressToken (IO ()) -> Map ProgressToken (IO ())
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ProgressToken
n (Async a -> ProgressCancelledException -> IO ()
forall e a. Exception e => Async a -> e -> IO ()
cancelWith Async a
a ProgressCancelledException
ProgressCancelledException)
{-# INLINE storeProgress #-}

deleteProgress :: MonadLsp config m => ProgressToken -> m ()
deleteProgress :: forall config (m :: * -> *).
MonadLsp config m =>
ProgressToken -> m ()
deleteProgress ProgressToken
n = (LanguageContextState config -> TVar (Map ProgressToken (IO ())))
-> (Map ProgressToken (IO ()) -> Map ProgressToken (IO ())) -> m ()
forall config (m :: * -> *) a.
MonadLsp config m =>
(LanguageContextState config -> TVar a) -> (a -> a) -> m ()
modifyState (ProgressData -> TVar (Map ProgressToken (IO ()))
progressCancel (ProgressData -> TVar (Map ProgressToken (IO ())))
-> (LanguageContextState config -> ProgressData)
-> LanguageContextState config
-> TVar (Map ProgressToken (IO ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextState config -> ProgressData
forall config. LanguageContextState config -> ProgressData
resProgressData) ((Map ProgressToken (IO ()) -> Map ProgressToken (IO ())) -> m ())
-> (Map ProgressToken (IO ()) -> Map ProgressToken (IO ())) -> m ()
forall a b. (a -> b) -> a -> b
$ ProgressToken
-> Map ProgressToken (IO ()) -> Map ProgressToken (IO ())
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ProgressToken
n
{-# INLINE deleteProgress #-}

-- Get a new id for the progress session and make a new one
getNewProgressId :: MonadLsp config m => m ProgressToken
getNewProgressId :: forall config (m :: * -> *). MonadLsp config m => m ProgressToken
getNewProgressId = do
  (LanguageContextState config -> TVar Int32)
-> (Int32 -> (ProgressToken, Int32)) -> m ProgressToken
forall config (m :: * -> *) s a.
MonadLsp config m =>
(LanguageContextState config -> TVar s) -> (s -> (a, s)) -> m a
stateState (ProgressData -> TVar Int32
progressNextId (ProgressData -> TVar Int32)
-> (LanguageContextState config -> ProgressData)
-> LanguageContextState config
-> TVar Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LanguageContextState config -> ProgressData
forall config. LanguageContextState config -> ProgressData
resProgressData) ((Int32 -> (ProgressToken, Int32)) -> m ProgressToken)
-> (Int32 -> (ProgressToken, Int32)) -> m ProgressToken
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 |? Text) -> ProgressToken
L.ProgressToken ((Int32 |? Text) -> ProgressToken)
-> (Int32 |? Text) -> ProgressToken
forall a b. (a -> b) -> a -> b
$ Int32 -> Int32 |? Text
forall a b. a -> a |? b
L.InL Int32
cur, Int32
next)
{-# INLINE getNewProgressId #-}

{- | The progress states we can be in.
See Note [Progress states]
-}
data ProgressState = ProgressInitial | ProgressStarted ProgressToken | ProgressEnded

withProgressBase ::
  forall c m a.
  MonadLsp c m =>
  Bool ->
  Text ->
  Maybe ProgressToken ->
  ProgressCancellable ->
  ((ProgressAmount -> m ()) -> m a) ->
  m a
withProgressBase :: forall c (m :: * -> *) a.
MonadLsp c m =>
Bool
-> Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((ProgressAmount -> m ()) -> m a)
-> m a
withProgressBase Bool
indefinite Text
title Maybe ProgressToken
clientToken ProgressCancellable
cancellable (ProgressAmount -> m ()) -> m a
f = do
  MVar ProgressState
progressState <- IO (MVar ProgressState) -> m (MVar ProgressState)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar ProgressState) -> m (MVar ProgressState))
-> IO (MVar ProgressState) -> m (MVar ProgressState)
forall a b. (a -> b) -> a -> b
$ ProgressState -> IO (MVar ProgressState)
forall a. a -> IO (MVar a)
newMVar ProgressState
ProgressInitial

  -- Until we start the progress reporting, track the current latest progress in an MVar, so when
  -- we do start we can start at the right point.
  let initialPercentage :: Maybe UInt
initialPercentage = if Bool
indefinite then Maybe UInt
forall a. Maybe a
Nothing else UInt -> Maybe UInt
forall a. a -> Maybe a
Just UInt
0
  MVar ProgressAmount
initialProgress <- IO (MVar ProgressAmount) -> m (MVar ProgressAmount)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar ProgressAmount) -> m (MVar ProgressAmount))
-> IO (MVar ProgressAmount) -> m (MVar ProgressAmount)
forall a b. (a -> b) -> a -> b
$ ProgressAmount -> IO (MVar ProgressAmount)
forall a. a -> IO (MVar a)
newMVar (Maybe UInt -> Maybe Text -> ProgressAmount
ProgressAmount Maybe UInt
initialPercentage Maybe Text
forall a. Maybe a
Nothing)

  let
    sendProgressReport :: (J.ToJSON r) => ProgressToken -> r -> m ()
    sendProgressReport :: forall r. ToJSON r => ProgressToken -> r -> m ()
sendProgressReport ProgressToken
token r
report = SServerMethod @'Notification ('Method_Progress @'ServerToClient)
-> MessageParams
     @'ServerToClient @'Notification ('Method_Progress @'ServerToClient)
-> m ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod @'Notification m
-> MessageParams @'ServerToClient @'Notification m -> f ()
sendNotification SServerMethod @'Notification ('Method_Progress @'ServerToClient)
forall {f :: MessageDirection}.
SMethod @f @'Notification ('Method_Progress @f)
SMethod_Progress (MessageParams
   @'ServerToClient @'Notification ('Method_Progress @'ServerToClient)
 -> m ())
-> MessageParams
     @'ServerToClient @'Notification ('Method_Progress @'ServerToClient)
-> m ()
forall a b. (a -> b) -> a -> b
$ ProgressToken -> Value -> ProgressParams
ProgressParams ProgressToken
token (Value -> ProgressParams) -> Value -> ProgressParams
forall a b. (a -> b) -> a -> b
$ r -> Value
forall a. ToJSON a => a -> Value
J.toJSON r
report

    -- See Note [Progress states]
    tryStart :: ProgressToken -> m ()
    tryStart :: ProgressToken -> m ()
tryStart ProgressToken
t = ((forall a. m a -> IO a) -> IO ()) -> m ()
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO ()) -> m ())
-> ((forall a. m a -> IO a) -> IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInBase -> MVar ProgressState -> (ProgressState -> IO ProgressState) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar ProgressState
progressState ((ProgressState -> IO ProgressState) -> IO ())
-> (ProgressState -> IO ProgressState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
      -- Can start if we are in the initial state, otherwise not
      ProgressState
ProgressInitial -> MVar ProgressAmount
-> (ProgressAmount -> IO ProgressState) -> IO ProgressState
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ProgressAmount
initialProgress ((ProgressAmount -> IO ProgressState) -> IO ProgressState)
-> (ProgressAmount -> IO ProgressState) -> IO ProgressState
forall a b. (a -> b) -> a -> b
$ \(ProgressAmount Maybe UInt
pct Maybe Text
msg) -> do
        let
          cancellable' :: Maybe Bool
cancellable' = case ProgressCancellable
cancellable of
            ProgressCancellable
Cancellable -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
            ProgressCancellable
NotCancellable -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
        m () -> IO ()
forall a. m a -> IO a
runInBase (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ ProgressToken -> WorkDoneProgressBegin -> m ()
forall r. ToJSON r => ProgressToken -> r -> m ()
sendProgressReport ProgressToken
t (WorkDoneProgressBegin -> m ()) -> WorkDoneProgressBegin -> m ()
forall a b. (a -> b) -> a -> b
$ AString "begin"
-> Text
-> Maybe Bool
-> Maybe Text
-> Maybe UInt
-> WorkDoneProgressBegin
WorkDoneProgressBegin AString "begin"
forall (s :: Symbol). KnownSymbol s => AString s
L.AString Text
title Maybe Bool
cancellable' Maybe Text
msg Maybe UInt
pct
        ProgressState -> IO ProgressState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProgressToken -> ProgressState
ProgressStarted ProgressToken
t)
      ProgressState
s -> ProgressState -> IO ProgressState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgressState
s
    -- See Note [Progress states]
    tryUpdate :: ProgressAmount -> m ()
    tryUpdate :: ProgressAmount -> m ()
tryUpdate (ProgressAmount Maybe UInt
pct Maybe Text
msg) = ((forall a. m a -> IO a) -> IO ()) -> m ()
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO ()) -> m ())
-> ((forall a. m a -> IO a) -> IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInBase -> MVar ProgressState -> (ProgressState -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ProgressState
progressState ((ProgressState -> IO ()) -> IO ())
-> (ProgressState -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
      -- If the progress has not started yet, then record the latest progress percentage
      ProgressState
ProgressInitial -> MVar ProgressAmount
-> (ProgressAmount -> IO ProgressAmount) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar ProgressAmount
initialProgress ((ProgressAmount -> IO ProgressAmount) -> IO ())
-> (ProgressAmount -> IO ProgressAmount) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(ProgressAmount Maybe UInt
oldPct Maybe Text
oldMsg) -> do
        let
          -- Update the percentage if the new one is not nothing
          newPct :: Maybe UInt
newPct = Maybe UInt
pct Maybe UInt -> Maybe UInt -> Maybe UInt
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe UInt
oldPct
          -- Update the message if the new one is not nothing
          newMsg :: Maybe Text
newMsg = Maybe Text
msg Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Text
oldMsg
        ProgressAmount -> IO ProgressAmount
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProgressAmount -> IO ProgressAmount)
-> ProgressAmount -> IO ProgressAmount
forall a b. (a -> b) -> a -> b
$ Maybe UInt -> Maybe Text -> ProgressAmount
ProgressAmount Maybe UInt
newPct Maybe Text
newMsg
      -- Just send the update, we don't need to worry about updating initialProgress any more
      ProgressStarted ProgressToken
t -> m () -> IO ()
forall a. m a -> IO a
runInBase (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ ProgressToken -> WorkDoneProgressReport -> m ()
forall r. ToJSON r => ProgressToken -> r -> m ()
sendProgressReport ProgressToken
t (WorkDoneProgressReport -> m ()) -> WorkDoneProgressReport -> m ()
forall a b. (a -> b) -> a -> b
$ AString "report"
-> Maybe Bool -> Maybe Text -> Maybe UInt -> WorkDoneProgressReport
WorkDoneProgressReport AString "report"
forall (s :: Symbol). KnownSymbol s => AString s
L.AString Maybe Bool
forall a. Maybe a
Nothing Maybe Text
msg Maybe UInt
pct
      ProgressState
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    -- See Note [Progress states]
    tryEnd :: m ()
    tryEnd :: m ()
tryEnd = ((forall a. m a -> IO a) -> IO ()) -> m ()
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO ()) -> m ())
-> ((forall a. m a -> IO a) -> IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInBase -> MVar ProgressState -> (ProgressState -> IO ProgressState) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar ProgressState
progressState ((ProgressState -> IO ProgressState) -> IO ())
-> (ProgressState -> IO ProgressState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
      -- Don't send an end message unless we successfully started
      ProgressStarted ProgressToken
t -> do
        m () -> IO ()
forall a. m a -> IO a
runInBase (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ ProgressToken -> WorkDoneProgressEnd -> m ()
forall r. ToJSON r => ProgressToken -> r -> m ()
sendProgressReport ProgressToken
t (WorkDoneProgressEnd -> m ()) -> WorkDoneProgressEnd -> m ()
forall a b. (a -> b) -> a -> b
$ AString "end" -> Maybe Text -> WorkDoneProgressEnd
WorkDoneProgressEnd AString "end"
forall (s :: Symbol). KnownSymbol s => AString s
L.AString Maybe Text
forall a. Maybe a
Nothing
        ProgressState -> IO ProgressState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgressState
ProgressEnded
      -- But in all cases we still want to transition state
      ProgressState
_ -> ProgressState -> IO ProgressState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgressState
ProgressEnded

    -- The progress token is also used as the cancellation ID
    -- See Note [Request cancellation]
    createAndStart :: m ProgressToken
    createAndStart :: m ProgressToken
createAndStart =
      case Maybe ProgressToken
clientToken of
        -- See Note [Client- versus server-initiated progress]
        -- Client-initiated progress
        Just ProgressToken
t -> ProgressToken -> m ()
tryStart ProgressToken
t m () -> m ProgressToken -> m ProgressToken
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProgressToken -> m ProgressToken
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgressToken
t
        -- Try server-initiated progress
        Maybe ProgressToken
Nothing -> do
          ProgressToken
t <- m ProgressToken
forall config (m :: * -> *). MonadLsp config m => m ProgressToken
getNewProgressId
          ClientCapabilities
clientCaps <- m ClientCapabilities
forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
getClientCapabilities

          -- If we don't have a progress token from the client and
          -- the client doesn't support server-initiated progress then
          -- there's nothing to do: we can't report progress.
          -- But we still need to return our internal token to use for
          -- cancellation
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ClientCapabilities -> Bool
clientSupportsServerInitiatedProgress ClientCapabilities
clientCaps)
            (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m (LspId @'ServerToClient 'Method_WindowWorkDoneProgressCreate)
-> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
            (m (LspId @'ServerToClient 'Method_WindowWorkDoneProgressCreate)
 -> m ())
-> m (LspId @'ServerToClient 'Method_WindowWorkDoneProgressCreate)
-> m ()
forall a b. (a -> b) -> a -> b
$
            -- Server-initiated progress
            -- See Note [Client- versus server-initiated progress]
            SServerMethod @'Request 'Method_WindowWorkDoneProgressCreate
-> MessageParams
     @'ServerToClient @'Request 'Method_WindowWorkDoneProgressCreate
-> (Either
      ResponseError
      (MessageResult
         @'ServerToClient @'Request 'Method_WindowWorkDoneProgressCreate)
    -> m ())
-> m (LspId @'ServerToClient 'Method_WindowWorkDoneProgressCreate)
forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod @'Request m
-> MessageParams @'ServerToClient @'Request m
-> (Either
      ResponseError (MessageResult @'ServerToClient @'Request m)
    -> f ())
-> f (LspId @'ServerToClient m)
sendRequest
              SServerMethod @'Request 'Method_WindowWorkDoneProgressCreate
SMethod_WindowWorkDoneProgressCreate
              (ProgressToken -> WorkDoneProgressCreateParams
WorkDoneProgressCreateParams ProgressToken
t)
            ((Either
    ResponseError
    (MessageResult
       @'ServerToClient @'Request 'Method_WindowWorkDoneProgressCreate)
  -> m ())
 -> m (LspId @'ServerToClient 'Method_WindowWorkDoneProgressCreate))
-> (Either
      ResponseError
      (MessageResult
         @'ServerToClient @'Request 'Method_WindowWorkDoneProgressCreate)
    -> m ())
-> m (LspId @'ServerToClient 'Method_WindowWorkDoneProgressCreate)
forall a b. (a -> b) -> a -> b
$ \case
              -- Successfully registered the token, we can now use it.
              -- So we go ahead and start. We do this as soon as we get the
              -- token back so the client gets feedback ASAP
              Right MessageResult
  @'ServerToClient @'Request 'Method_WindowWorkDoneProgressCreate
_ -> ProgressToken -> m ()
tryStart ProgressToken
t
              -- The client sent us an error, we can't use the token. So we remain
              -- in ProgressInitial and don't send any progress updates ever
              -- TODO: log the error
              Left ResponseError
_err -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

          ProgressToken -> m ProgressToken
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgressToken
t

    end :: ProgressToken -> m ()
    end :: ProgressToken -> m ()
end ProgressToken
cancellationId = do
      m ()
tryEnd
      -- Delete the progress cancellation from the map
      -- If we don't do this then it's easy to leak things as the map contains any IO action.
      ProgressToken -> m ()
forall config (m :: * -> *).
MonadLsp config m =>
ProgressToken -> m ()
deleteProgress ProgressToken
cancellationId

  -- Send the begin and done notifications via 'bracket' so that they are always fired
  ((forall a. m a -> IO a) -> IO a) -> m a
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInBase ->
    IO ProgressToken
-> (ProgressToken -> IO ()) -> (ProgressToken -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (m ProgressToken -> IO ProgressToken
forall a. m a -> IO a
runInBase m ProgressToken
createAndStart) (m () -> IO ()
forall a. m a -> IO a
runInBase (m () -> IO ())
-> (ProgressToken -> m ()) -> ProgressToken -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgressToken -> m ()
end) ((ProgressToken -> IO a) -> IO a)
-> (ProgressToken -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ProgressToken
cancellationId -> do
      -- Run f asynchronously
      Async a
aid <- IO a -> IO (Async a)
forall a. IO a -> IO (Async a)
async (IO a -> IO (Async a)) -> IO a -> IO (Async a)
forall a b. (a -> b) -> a -> b
$ m a -> IO a
forall a. m a -> IO a
runInBase (m a -> IO a) -> m a -> IO a
forall a b. (a -> b) -> a -> b
$ (ProgressAmount -> m ()) -> m a
f ProgressAmount -> m ()
tryUpdate
      -- Always store the thread ID so we can cancel, see Note [Request cancellation]
      m () -> IO ()
forall a. m a -> IO a
runInBase (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ ProgressToken -> Async a -> m ()
forall config (m :: * -> *) a.
MonadLsp config m =>
ProgressToken -> Async a -> m ()
storeProgress ProgressToken
cancellationId Async a
aid
      Async a -> IO a
forall a. Async a -> IO a
wait Async a
aid

clientSupportsServerInitiatedProgress :: L.ClientCapabilities -> Bool
clientSupportsServerInitiatedProgress :: ClientCapabilities -> Bool
clientSupportsServerInitiatedProgress ClientCapabilities
caps = 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 WindowClientCapabilities
 -> Const @(*) (First Bool) (Maybe WindowClientCapabilities))
-> ClientCapabilities -> Const @(*) (First Bool) ClientCapabilities
forall s a. HasWindow s a => Lens' s a
Lens' ClientCapabilities (Maybe WindowClientCapabilities)
L.window ((Maybe WindowClientCapabilities
  -> Const @(*) (First Bool) (Maybe WindowClientCapabilities))
 -> ClientCapabilities
 -> Const @(*) (First Bool) ClientCapabilities)
-> ((Bool -> Const @(*) (First Bool) Bool)
    -> Maybe WindowClientCapabilities
    -> Const @(*) (First Bool) (Maybe WindowClientCapabilities))
-> Getting (First Bool) ClientCapabilities Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WindowClientCapabilities
 -> Const @(*) (First Bool) WindowClientCapabilities)
-> Maybe WindowClientCapabilities
-> Const @(*) (First Bool) (Maybe WindowClientCapabilities)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((WindowClientCapabilities
  -> Const @(*) (First Bool) WindowClientCapabilities)
 -> Maybe WindowClientCapabilities
 -> Const @(*) (First Bool) (Maybe WindowClientCapabilities))
-> ((Bool -> Const @(*) (First Bool) Bool)
    -> WindowClientCapabilities
    -> Const @(*) (First Bool) WindowClientCapabilities)
-> (Bool -> Const @(*) (First Bool) Bool)
-> Maybe WindowClientCapabilities
-> Const @(*) (First Bool) (Maybe WindowClientCapabilities)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Const @(*) (First Bool) (Maybe Bool))
-> WindowClientCapabilities
-> Const @(*) (First Bool) WindowClientCapabilities
forall s a. HasWorkDoneProgress s a => Lens' s a
Lens' WindowClientCapabilities (Maybe Bool)
L.workDoneProgress ((Maybe Bool -> Const @(*) (First Bool) (Maybe Bool))
 -> WindowClientCapabilities
 -> Const @(*) (First Bool) WindowClientCapabilities)
-> ((Bool -> Const @(*) (First Bool) Bool)
    -> Maybe Bool -> Const @(*) (First Bool) (Maybe Bool))
-> (Bool -> Const @(*) (First Bool) Bool)
-> WindowClientCapabilities
-> Const @(*) (First Bool) WindowClientCapabilities
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
{-# INLINE clientSupportsServerInitiatedProgress #-}

{- |
Wrapper for reporting progress to the client during a long running task.
-}
withProgress ::
  MonadLsp c m =>
  -- | The title of the progress operation
  Text ->
  -- | The progress token provided by the client in the method params, if any
  Maybe ProgressToken ->
  -- | Whether or not this operation is cancellable. If true, the user will be
  -- shown a button to allow cancellation. Note that requests can still be cancelled
  -- even if this is not set.
  ProgressCancellable ->
  -- | An update function to pass progress updates to
  ((ProgressAmount -> m ()) -> m a) ->
  m a
withProgress :: forall c (m :: * -> *) a.
MonadLsp c m =>
Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((ProgressAmount -> m ()) -> m a)
-> m a
withProgress Text
title Maybe ProgressToken
clientToken ProgressCancellable
cancellable (ProgressAmount -> m ()) -> m a
f = Bool
-> Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((ProgressAmount -> m ()) -> m a)
-> m a
forall c (m :: * -> *) a.
MonadLsp c m =>
Bool
-> Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((ProgressAmount -> m ()) -> m a)
-> m a
withProgressBase Bool
False Text
title Maybe ProgressToken
clientToken ProgressCancellable
cancellable (ProgressAmount -> m ()) -> m a
f

{- |
Same as 'withProgress', but for processes that do not report the precentage complete.
-}
withIndefiniteProgress ::
  MonadLsp c m =>
  -- | The title of the progress operation
  Text ->
  -- | The progress token provided by the client in the method params, if any
  Maybe ProgressToken ->
  -- | Whether or not this operation is cancellable. If true, the user will be
  -- shown a button to allow cancellation. Note that requests can still be cancelled
  -- even if this is not set.
  ProgressCancellable ->
  -- | An update function to pass progress updates to
  ((Text -> m ()) -> m a) ->
  m a
withIndefiniteProgress :: forall c (m :: * -> *) a.
MonadLsp c m =>
Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((Text -> m ()) -> m a)
-> m a
withIndefiniteProgress Text
title Maybe ProgressToken
clientToken ProgressCancellable
cancellable (Text -> m ()) -> m a
f =
  Bool
-> Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((ProgressAmount -> m ()) -> m a)
-> m a
forall c (m :: * -> *) a.
MonadLsp c m =>
Bool
-> Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((ProgressAmount -> m ()) -> m a)
-> m a
withProgressBase Bool
True Text
title Maybe ProgressToken
clientToken ProgressCancellable
cancellable (\ProgressAmount -> m ()
update -> (Text -> m ()) -> m a
f (\Text
msg -> ProgressAmount -> m ()
update (Maybe UInt -> Maybe Text -> ProgressAmount
ProgressAmount Maybe UInt
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
msg))))

-- ---------------------------------------------------------------------

{- | Aggregate all diagnostics pertaining to a particular version of a document,
 by source, and sends a @textDocument/publishDiagnostics@ notification with
 the total (limited by the first parameter) whenever it is updated.
-}
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)

-- ---------------------------------------------------------------------

{- | Remove all diagnostics from a particular source, and send the updates to
 the client.
-}
flushDiagnosticsBySource ::
  MonadLsp config m =>
  -- | Max number of diagnostics to send
  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
      -- Send the updated diagnostics to the client
      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)

-- ---------------------------------------------------------------------

{- | The changes in a workspace edit should be applied from the end of the file
 toward the start. Sort them into this order.
-}
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

--------------------------------------------------------------------------------
-- CONFIG
--------------------------------------------------------------------------------

-- | Given a new config object, try to update our config with it.
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

{- | Send a `worksapce/configuration` request to update the server's config.

 This is called automatically in response to `workspace/didChangeConfiguration` notifications
 from the client, so should not normally be called manually.
-}
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
      ResponseError
      (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
      ResponseError (MessageResult @'ServerToClient @'Request m)
    -> f ())
-> f (LspId @'ServerToClient m)
sendRequest SServerMethod @'Request 'Method_WorkspaceConfiguration
SMethod_WorkspaceConfiguration ([ConfigurationItem] -> ConfigurationParams
ConfigurationParams [Maybe Text -> Maybe Text -> ConfigurationItem
ConfigurationItem Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
section)]) ((Either
    ResponseError
    (MessageResult
       @'ServerToClient @'Request 'Method_WorkspaceConfiguration)
  -> m ())
 -> m (LspId @'ServerToClient 'Method_WorkspaceConfiguration))
-> (Either
      ResponseError
      (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 ResponseError
err -> LogAction m (WithSeverity LspCoreLog)
logger LogAction m (WithSeverity LspCoreLog)
-> WithSeverity LspCoreLog -> m ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& ResponseError -> LspCoreLog
BadConfigurationResponse ResponseError
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

{- Note [LSP configuration]
LSP configuration is a huge mess.
- The configuration model of the client is not specified
- Many of the configuration messages are not specified in what they should return

In particular, configuration appears in three places:
1. The `initializationOptions` field of the `initialize` request.
  - The contents of this are unspecified. "User provided initialization options".
2. The `settings` field of the `workspace/didChangeConfiguration` notification.
  - The contents of this are unspecified. "The actual changed settings".
3. The `section` field of the response to the `workspace/configuration` request.
  - This at least says it should be the settings corresponding to the sections
    specified in the request.

It's very hard to know what to do here. In particular, the first two cases seem
like they could include arbitrary configuration from the client that might not
relate to you. How you locate "your" settings is unclear.

We are on firmer ground with case 3. Then at least it seems that we can pick
a configuration section, just always ask for that, and require clients to use
that for our settings. Furthermore, this is the method that is encouraged by the
specification designers: https://github.com/microsoft/language-server-protocol/issues/567#issuecomment-420589320.

For this reason we mostly try and rely on `workspace/configuration`. That means
three things:
- We require servers to give a specific configuration section for us to use
  when requesting configuration.
- We can try and make sense of `initializationOptions`, but regardless we should
  send a `workspace/configuration` request afterwards (in the handler for the
  `initialized` notification, which is the earliest we can send messages:
  https://github.com/microsoft/language-server-protocol/issues/567#issuecomment-953772465)
- We can try and make sense of `didChangeConfiguration`, but regardless we should
  send a `workspace/configuration` request afterwards

We do try to make sense of the first two cases also, especially because clients do
not have to support `workspace/configuration`! In practice,
many clients seem to follow the sensible approach laid out here:
https://github.com/microsoft/language-server-protocol/issues/972#issuecomment-626668243

To make this work, we try to be tolerant by using the following strategy.
When we receive a configuration object from any of the sources above, we first
check to see if it has a field corresponding to our configuration section. If it
does, then we assume that it our config and try to parse it. If it does not, we
try to parse the entire config object. This hopefully lets us handle a variety
of sensible cases where the client sends us mostly our config, either wrapped
in our section or not.
-}

{- Note [Progress states]
Creating and using progress actually requires a small state machine.
The states are:
- ProgressInitial: we haven't got a progress token
- ProgressStarted: we have got a progress token and started the progress
- ProgressEnded: we have ended the progress

Notably,
1. We can't send updates except in ProgressStarted
2. We can't start the progress until we get the token back
   - This means that we may have to wait to send the start report, we can't necessarily
     send it immediately!
3. We can end if we haven't started (by just transitioning state), but we shouldn't
   send an end report.

We can have concurrent updates to the state, since we sometimes transiton states
in response to the client. In particular, for server-initiated progress, we have
to wait for the client to confirm the token until we can enter ProgressStarted.
-}

{- Note [Client- versus server-initiated progress]
The protocol supports both client- and server-initiated progress. Client-initiated progress
is simpler: the client gives you a progress token, and then you use that to report progress.
Server-initiated progress is more complex: you need to send a request to the client to tell
them about the token you want to use, and only after that can you send updates using it.
-}

{- Note [Request cancellation]
Request cancellation is a bit strange.

We need to in fact assume that all requests are cancellable, see
https://github.com/microsoft/language-server-protocol/issues/1159.

The 'cancellable' property that we can set when making progress reports just
affects whether the client should show a 'Cancel' button to the user in the UI.
The client can still always choose to cancel for another reason.
-}