{-# LANGUAGE BlockArguments        #-}
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE CUSKs                 #-}
{-# LANGUAGE DefaultSignatures     #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MonadComprehensions   #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE ViewPatterns          #-}
module Ide.Types
( PluginDescriptor(..), defaultPluginDescriptor, defaultCabalPluginDescriptor
, defaultPluginPriority
, describePlugin
, IdeCommand(..)
, IdeMethod(..)
, IdeNotification(..)
, IdePlugins(IdePlugins, ipMap)
, DynFlagsModifications(..)
, Config(..), PluginConfig(..), CheckParents(..), SessionLoadingPreferenceConfig(..)
, ConfigDescriptor(..), defaultConfigDescriptor, configForPlugin
, CustomConfig(..), mkCustomConfig
, FallbackCodeActionParams(..)
, FormattingType(..), FormattingMethod, FormattingHandler, mkFormattingHandlers
, HasTracing(..)
, PluginCommand(..), CommandId(..), CommandFunction, mkLspCommand, mkLspCmdId
, PluginId(..)
, PluginHandler(..), mkPluginHandler
, HandlerM, runHandlerM, pluginGetClientCapabilities, pluginGetVirtualFile, pluginGetVersionedTextDoc, pluginSendNotification, pluginSendRequest, pluginWithIndefiniteProgress
, PluginHandlers(..)
, PluginMethod(..)
, PluginMethodHandler
, PluginNotificationHandler(..), mkPluginNotificationHandler
, PluginNotificationHandlers(..)
, PluginRequestMethod(..)
, getProcessID, getPid
, installSigUsr1Handler
, lookupCommandProvider
, ResolveFunction
, mkResolveHandler
)
    where

#ifdef mingw32_HOST_OS

import qualified System.Win32.Process          as P (getCurrentProcessId)

#else

import qualified System.Posix.Process          as P (getProcessID)
import           System.Posix.Signals

#endif

import           Control.Applicative           ((<|>))
import           Control.Arrow                 ((&&&))
import           Control.Lens                  (_Just, view, (.~), (?~), (^.),
                                                (^?))
import           Control.Monad                 (void)
import           Control.Monad.Error.Class     (MonadError (throwError))
import           Control.Monad.IO.Class        (MonadIO)
import           Control.Monad.Trans.Class     (MonadTrans (lift))
import           Control.Monad.Trans.Except    (ExceptT, runExceptT)
import           Data.Aeson                    hiding (Null, defaultOptions)
import qualified Data.Aeson.Types              as A
import           Data.Default
import           Data.Dependent.Map            (DMap)
import qualified Data.Dependent.Map            as DMap
import qualified Data.DList                    as DList
import           Data.GADT.Compare
import           Data.Hashable                 (Hashable)
import           Data.HashMap.Strict           (HashMap)
import qualified Data.HashMap.Strict           as HashMap
import           Data.Kind                     (Type)
import           Data.List.Extra               (find, sortOn)
import           Data.List.NonEmpty            (NonEmpty (..), toList)
import qualified Data.Map                      as Map
import           Data.Maybe
import           Data.Ord
import           Data.Semigroup
import           Data.String
import qualified Data.Text                     as T
import           Data.Text.Encoding            (encodeUtf8)
import           Development.IDE.Graph
import           GHC                           (DynFlags)
import           GHC.Generics
import           Ide.Plugin.Error
import           Ide.Plugin.HandleRequestTypes
import           Ide.Plugin.Properties
import qualified Language.LSP.Protocol.Lens    as L
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types
import           Language.LSP.Server
import           Language.LSP.VFS
import           Numeric.Natural
import           OpenTelemetry.Eventlog
import           Options.Applicative           (ParserInfo)
import           Prettyprinter                 as PP
import           System.FilePath
import           System.IO.Unsafe
import           Text.Regex.TDFA.Text          ()
import           UnliftIO                      (MonadUnliftIO)

#if !MIN_VERSION_base(4,20,0)
import           Data.Foldable                 (foldl')
#endif

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

data IdePlugins ideState = IdePlugins_
  { forall ideState.
IdePlugins ideState -> HashMap PluginId (PluginDescriptor ideState)
ipMap_                :: HashMap PluginId (PluginDescriptor ideState)
  , forall ideState. IdePlugins ideState -> CommandId -> Maybe PluginId
lookupCommandProvider :: CommandId -> Maybe PluginId
  }

-- | Smart constructor that deduplicates plugins
pattern IdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState
pattern $mIdePlugins :: forall {r} {ideState}.
IdePlugins ideState
-> ([PluginDescriptor ideState] -> r) -> ((# #) -> r) -> r
$bIdePlugins :: forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
IdePlugins{forall ideState. IdePlugins ideState -> [PluginDescriptor ideState]
ipMap} <- IdePlugins_ (sortOn (Down . pluginPriority) . HashMap.elems -> ipMap) _
  where
    IdePlugins [PluginDescriptor ideState]
ipMap = IdePlugins_{$sel:ipMap_:IdePlugins_ :: HashMap PluginId (PluginDescriptor ideState)
ipMap_ = [(PluginId, PluginDescriptor ideState)]
-> HashMap PluginId (PluginDescriptor ideState)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(PluginId, PluginDescriptor ideState)]
 -> HashMap PluginId (PluginDescriptor ideState))
-> [(PluginId, PluginDescriptor ideState)]
-> HashMap PluginId (PluginDescriptor ideState)
forall a b. (a -> b) -> a -> b
$ (PluginDescriptor ideState -> PluginId
forall ideState. PluginDescriptor ideState -> PluginId
pluginId (PluginDescriptor ideState -> PluginId)
-> (PluginDescriptor ideState -> PluginDescriptor ideState)
-> PluginDescriptor ideState
-> (PluginId, PluginDescriptor ideState)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& PluginDescriptor ideState -> PluginDescriptor ideState
forall a. a -> a
id) (PluginDescriptor ideState
 -> (PluginId, PluginDescriptor ideState))
-> [PluginDescriptor ideState]
-> [(PluginId, PluginDescriptor ideState)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PluginDescriptor ideState]
ipMap
                                  , $sel:lookupCommandProvider:IdePlugins_ :: CommandId -> Maybe PluginId
lookupCommandProvider = [PluginDescriptor ideState] -> CommandId -> Maybe PluginId
forall a. [PluginDescriptor a] -> CommandId -> Maybe PluginId
lookupPluginId [PluginDescriptor ideState]
ipMap
                                  }
{-# COMPLETE IdePlugins #-}

instance Semigroup (IdePlugins a) where
  (IdePlugins_ HashMap PluginId (PluginDescriptor a)
a CommandId -> Maybe PluginId
f) <> :: IdePlugins a -> IdePlugins a -> IdePlugins a
<> (IdePlugins_ HashMap PluginId (PluginDescriptor a)
b CommandId -> Maybe PluginId
g) = HashMap PluginId (PluginDescriptor a)
-> (CommandId -> Maybe PluginId) -> IdePlugins a
forall ideState.
HashMap PluginId (PluginDescriptor ideState)
-> (CommandId -> Maybe PluginId) -> IdePlugins ideState
IdePlugins_ (HashMap PluginId (PluginDescriptor a)
a HashMap PluginId (PluginDescriptor a)
-> HashMap PluginId (PluginDescriptor a)
-> HashMap PluginId (PluginDescriptor a)
forall a. Semigroup a => a -> a -> a
<> HashMap PluginId (PluginDescriptor a)
b) (\CommandId
x -> CommandId -> Maybe PluginId
f CommandId
x Maybe PluginId -> Maybe PluginId -> Maybe PluginId
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CommandId -> Maybe PluginId
g CommandId
x)

instance Monoid (IdePlugins a) where
  mempty :: IdePlugins a
mempty = HashMap PluginId (PluginDescriptor a)
-> (CommandId -> Maybe PluginId) -> IdePlugins a
forall ideState.
HashMap PluginId (PluginDescriptor ideState)
-> (CommandId -> Maybe PluginId) -> IdePlugins ideState
IdePlugins_ HashMap PluginId (PluginDescriptor a)
forall a. Monoid a => a
mempty (Maybe PluginId -> CommandId -> Maybe PluginId
forall a b. a -> b -> a
const Maybe PluginId
forall a. Maybe a
Nothing)

-- | Lookup the plugin that exposes a particular command
lookupPluginId :: [PluginDescriptor a] -> CommandId -> Maybe PluginId
lookupPluginId :: forall a. [PluginDescriptor a] -> CommandId -> Maybe PluginId
lookupPluginId [PluginDescriptor a]
ls CommandId
cmd = PluginDescriptor a -> PluginId
forall ideState. PluginDescriptor ideState -> PluginId
pluginId (PluginDescriptor a -> PluginId)
-> Maybe (PluginDescriptor a) -> Maybe PluginId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PluginDescriptor a -> Bool)
-> [PluginDescriptor a] -> Maybe (PluginDescriptor a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find PluginDescriptor a -> Bool
go [PluginDescriptor a]
ls
  where
    go :: PluginDescriptor a -> Bool
go PluginDescriptor a
desc = CommandId
cmd CommandId -> [CommandId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (PluginCommand a -> CommandId) -> [PluginCommand a] -> [CommandId]
forall a b. (a -> b) -> [a] -> [b]
map PluginCommand a -> CommandId
forall ideState. PluginCommand ideState -> CommandId
commandId (PluginDescriptor a -> [PluginCommand a]
forall ideState.
PluginDescriptor ideState -> [PluginCommand ideState]
pluginCommands PluginDescriptor a
desc)

-- | Hooks for modifying the 'DynFlags' at different times of the compilation
-- process. Plugins can install a 'DynFlagsModifications' via
-- 'pluginModifyDynflags' in their 'PluginDescriptor'.
data DynFlagsModifications =
  DynFlagsModifications
    { -- | Invoked immediately at the package level. Changes to the 'DynFlags'
      -- made in 'dynFlagsModifyGlobal' are guaranteed to be seen everywhere in
      -- the compilation pipeline.
      DynFlagsModifications -> DynFlags -> DynFlags
dynFlagsModifyGlobal :: DynFlags -> DynFlags
      -- | Invoked just before the parsing step, and reset immediately
      -- afterwards. 'dynFlagsModifyParser' allows plugins to enable language
      -- extensions only during parsing. for example, to let them enable
      -- certain pieces of syntax.
    , DynFlagsModifications -> DynFlags -> DynFlags
dynFlagsModifyParser :: DynFlags -> DynFlags
    }

instance Semigroup DynFlagsModifications where
  DynFlagsModifications DynFlags -> DynFlags
g1 DynFlags -> DynFlags
p1 <> :: DynFlagsModifications
-> DynFlagsModifications -> DynFlagsModifications
<> DynFlagsModifications DynFlags -> DynFlags
g2 DynFlags -> DynFlags
p2 =
    (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlagsModifications
DynFlagsModifications (DynFlags -> DynFlags
g2 (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> DynFlags
g1) (DynFlags -> DynFlags
p2 (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> DynFlags
p1)

instance Monoid DynFlagsModifications where
  mempty :: DynFlagsModifications
mempty = (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlagsModifications
DynFlagsModifications DynFlags -> DynFlags
forall a. a -> a
id DynFlags -> DynFlags
forall a. a -> a
id

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

newtype IdeCommand state = IdeCommand (state -> IO ())
instance Show (IdeCommand st) where show :: IdeCommand st -> String
show IdeCommand st
_ = String
"<ide command>"

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

-- | We (initially anyway) mirror the hie configuration, so that existing
-- clients can simply switch executable and not have any nasty surprises.  There
-- will initially be surprises relating to config options being ignored though.
data Config =
  Config
    { Config -> CheckParents
checkParents            :: CheckParents
    , Config -> Bool
checkProject            :: !Bool
    , Config -> Text
formattingProvider      :: !T.Text
    , Config -> Text
cabalFormattingProvider :: !T.Text
    , Config -> Int
maxCompletions          :: !Int
    , Config -> SessionLoadingPreferenceConfig
sessionLoading          :: !SessionLoadingPreferenceConfig
    , Config -> Map PluginId PluginConfig
plugins                 :: !(Map.Map PluginId PluginConfig)
    } deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Config -> ShowS
showsPrec :: Int -> Config -> ShowS
$cshow :: Config -> String
show :: Config -> String
$cshowList :: [Config] -> ShowS
showList :: [Config] -> ShowS
Show,Config -> Config -> Bool
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
/= :: Config -> Config -> Bool
Eq)

instance ToJSON Config where
  toJSON :: Config -> Value
toJSON Config{Bool
Int
Map PluginId PluginConfig
Text
SessionLoadingPreferenceConfig
CheckParents
$sel:checkParents:Config :: Config -> CheckParents
$sel:checkProject:Config :: Config -> Bool
$sel:formattingProvider:Config :: Config -> Text
$sel:cabalFormattingProvider:Config :: Config -> Text
$sel:maxCompletions:Config :: Config -> Int
$sel:sessionLoading:Config :: Config -> SessionLoadingPreferenceConfig
$sel:plugins:Config :: Config -> Map PluginId PluginConfig
checkParents :: CheckParents
checkProject :: Bool
formattingProvider :: Text
cabalFormattingProvider :: Text
maxCompletions :: Int
sessionLoading :: SessionLoadingPreferenceConfig
plugins :: Map PluginId PluginConfig
..} =
    [Pair] -> Value
object [ Key
"checkParents"                Key -> CheckParents -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= CheckParents
checkParents
           , Key
"checkProject"                Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
checkProject
           , Key
"formattingProvider"          Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
formattingProvider
           , Key
"cabalFormattingProvider"     Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
cabalFormattingProvider
           , Key
"maxCompletions"              Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
maxCompletions
           , Key
"sessionLoading"              Key -> SessionLoadingPreferenceConfig -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SessionLoadingPreferenceConfig
sessionLoading
           , Key
"plugin"                      Key -> Map Text PluginConfig -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (PluginId -> Text)
-> Map PluginId PluginConfig -> Map Text PluginConfig
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic (\(PluginId Text
p) -> Text
p) Map PluginId PluginConfig
plugins
           ]

instance Default Config where
  def :: Config
def = Config
    { $sel:checkParents:Config :: CheckParents
checkParents                = CheckParents
CheckOnSave
    , $sel:checkProject:Config :: Bool
checkProject                = Bool
True
    , $sel:formattingProvider:Config :: Text
formattingProvider          = Text
"ormolu"
    -- , formattingProvider          = "floskell"
    -- , formattingProvider          = "stylish-haskell"
    , $sel:cabalFormattingProvider:Config :: Text
cabalFormattingProvider     = Text
"cabal-gild"
    -- , cabalFormattingProvider     = "cabal-fmt"
    -- this string value needs to kept in sync with the value provided in HlsPlugins
    , $sel:maxCompletions:Config :: Int
maxCompletions              = Int
40
    , $sel:sessionLoading:Config :: SessionLoadingPreferenceConfig
sessionLoading              = SessionLoadingPreferenceConfig
PreferSingleComponentLoading
    , $sel:plugins:Config :: Map PluginId PluginConfig
plugins                     = Map PluginId PluginConfig
forall a. Monoid a => a
mempty
    }

data CheckParents
    -- Note that ordering of constructors is meaningful and must be monotonically
    -- increasing in the scenarios where parents are checked
    = NeverCheck
    | CheckOnSave
    | AlwaysCheck
  deriving stock (CheckParents -> CheckParents -> Bool
(CheckParents -> CheckParents -> Bool)
-> (CheckParents -> CheckParents -> Bool) -> Eq CheckParents
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CheckParents -> CheckParents -> Bool
== :: CheckParents -> CheckParents -> Bool
$c/= :: CheckParents -> CheckParents -> Bool
/= :: CheckParents -> CheckParents -> Bool
Eq, Eq CheckParents
Eq CheckParents =>
(CheckParents -> CheckParents -> Ordering)
-> (CheckParents -> CheckParents -> Bool)
-> (CheckParents -> CheckParents -> Bool)
-> (CheckParents -> CheckParents -> Bool)
-> (CheckParents -> CheckParents -> Bool)
-> (CheckParents -> CheckParents -> CheckParents)
-> (CheckParents -> CheckParents -> CheckParents)
-> Ord CheckParents
CheckParents -> CheckParents -> Bool
CheckParents -> CheckParents -> Ordering
CheckParents -> CheckParents -> CheckParents
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CheckParents -> CheckParents -> Ordering
compare :: CheckParents -> CheckParents -> Ordering
$c< :: CheckParents -> CheckParents -> Bool
< :: CheckParents -> CheckParents -> Bool
$c<= :: CheckParents -> CheckParents -> Bool
<= :: CheckParents -> CheckParents -> Bool
$c> :: CheckParents -> CheckParents -> Bool
> :: CheckParents -> CheckParents -> Bool
$c>= :: CheckParents -> CheckParents -> Bool
>= :: CheckParents -> CheckParents -> Bool
$cmax :: CheckParents -> CheckParents -> CheckParents
max :: CheckParents -> CheckParents -> CheckParents
$cmin :: CheckParents -> CheckParents -> CheckParents
min :: CheckParents -> CheckParents -> CheckParents
Ord, Int -> CheckParents -> ShowS
[CheckParents] -> ShowS
CheckParents -> String
(Int -> CheckParents -> ShowS)
-> (CheckParents -> String)
-> ([CheckParents] -> ShowS)
-> Show CheckParents
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CheckParents -> ShowS
showsPrec :: Int -> CheckParents -> ShowS
$cshow :: CheckParents -> String
show :: CheckParents -> String
$cshowList :: [CheckParents] -> ShowS
showList :: [CheckParents] -> ShowS
Show, (forall x. CheckParents -> Rep CheckParents x)
-> (forall x. Rep CheckParents x -> CheckParents)
-> Generic CheckParents
forall x. Rep CheckParents x -> CheckParents
forall x. CheckParents -> Rep CheckParents x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CheckParents -> Rep CheckParents x
from :: forall x. CheckParents -> Rep CheckParents x
$cto :: forall x. Rep CheckParents x -> CheckParents
to :: forall x. Rep CheckParents x -> CheckParents
Generic)
  deriving anyclass (Maybe CheckParents
Value -> Parser [CheckParents]
Value -> Parser CheckParents
(Value -> Parser CheckParents)
-> (Value -> Parser [CheckParents])
-> Maybe CheckParents
-> FromJSON CheckParents
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser CheckParents
parseJSON :: Value -> Parser CheckParents
$cparseJSONList :: Value -> Parser [CheckParents]
parseJSONList :: Value -> Parser [CheckParents]
$comittedField :: Maybe CheckParents
omittedField :: Maybe CheckParents
FromJSON, [CheckParents] -> Value
[CheckParents] -> Encoding
CheckParents -> Bool
CheckParents -> Value
CheckParents -> Encoding
(CheckParents -> Value)
-> (CheckParents -> Encoding)
-> ([CheckParents] -> Value)
-> ([CheckParents] -> Encoding)
-> (CheckParents -> Bool)
-> ToJSON CheckParents
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: CheckParents -> Value
toJSON :: CheckParents -> Value
$ctoEncoding :: CheckParents -> Encoding
toEncoding :: CheckParents -> Encoding
$ctoJSONList :: [CheckParents] -> Value
toJSONList :: [CheckParents] -> Value
$ctoEncodingList :: [CheckParents] -> Encoding
toEncodingList :: [CheckParents] -> Encoding
$comitField :: CheckParents -> Bool
omitField :: CheckParents -> Bool
ToJSON)


data SessionLoadingPreferenceConfig
    = PreferSingleComponentLoading
    -- ^ Always load only a singleComponent when a new component
    -- is discovered.
    | PreferMultiComponentLoading
    -- ^ Always prefer loading multiple components in the cradle
    -- at once. This might not be always possible, if the tool doesn't
    -- support multiple components loading.
    --
    -- The cradle can decide how to handle these situations, and whether
    -- to honour the preference at all.
  deriving stock (SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> Bool
(SessionLoadingPreferenceConfig
 -> SessionLoadingPreferenceConfig -> Bool)
-> (SessionLoadingPreferenceConfig
    -> SessionLoadingPreferenceConfig -> Bool)
-> Eq SessionLoadingPreferenceConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> Bool
== :: SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> Bool
$c/= :: SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> Bool
/= :: SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> Bool
Eq, Eq SessionLoadingPreferenceConfig
Eq SessionLoadingPreferenceConfig =>
(SessionLoadingPreferenceConfig
 -> SessionLoadingPreferenceConfig -> Ordering)
-> (SessionLoadingPreferenceConfig
    -> SessionLoadingPreferenceConfig -> Bool)
-> (SessionLoadingPreferenceConfig
    -> SessionLoadingPreferenceConfig -> Bool)
-> (SessionLoadingPreferenceConfig
    -> SessionLoadingPreferenceConfig -> Bool)
-> (SessionLoadingPreferenceConfig
    -> SessionLoadingPreferenceConfig -> Bool)
-> (SessionLoadingPreferenceConfig
    -> SessionLoadingPreferenceConfig
    -> SessionLoadingPreferenceConfig)
-> (SessionLoadingPreferenceConfig
    -> SessionLoadingPreferenceConfig
    -> SessionLoadingPreferenceConfig)
-> Ord SessionLoadingPreferenceConfig
SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> Bool
SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> Ordering
SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> SessionLoadingPreferenceConfig
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> Ordering
compare :: SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> Ordering
$c< :: SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> Bool
< :: SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> Bool
$c<= :: SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> Bool
<= :: SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> Bool
$c> :: SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> Bool
> :: SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> Bool
$c>= :: SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> Bool
>= :: SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> Bool
$cmax :: SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> SessionLoadingPreferenceConfig
max :: SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> SessionLoadingPreferenceConfig
$cmin :: SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> SessionLoadingPreferenceConfig
min :: SessionLoadingPreferenceConfig
-> SessionLoadingPreferenceConfig -> SessionLoadingPreferenceConfig
Ord, Int -> SessionLoadingPreferenceConfig -> ShowS
[SessionLoadingPreferenceConfig] -> ShowS
SessionLoadingPreferenceConfig -> String
(Int -> SessionLoadingPreferenceConfig -> ShowS)
-> (SessionLoadingPreferenceConfig -> String)
-> ([SessionLoadingPreferenceConfig] -> ShowS)
-> Show SessionLoadingPreferenceConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SessionLoadingPreferenceConfig -> ShowS
showsPrec :: Int -> SessionLoadingPreferenceConfig -> ShowS
$cshow :: SessionLoadingPreferenceConfig -> String
show :: SessionLoadingPreferenceConfig -> String
$cshowList :: [SessionLoadingPreferenceConfig] -> ShowS
showList :: [SessionLoadingPreferenceConfig] -> ShowS
Show, (forall x.
 SessionLoadingPreferenceConfig
 -> Rep SessionLoadingPreferenceConfig x)
-> (forall x.
    Rep SessionLoadingPreferenceConfig x
    -> SessionLoadingPreferenceConfig)
-> Generic SessionLoadingPreferenceConfig
forall x.
Rep SessionLoadingPreferenceConfig x
-> SessionLoadingPreferenceConfig
forall x.
SessionLoadingPreferenceConfig
-> Rep SessionLoadingPreferenceConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
SessionLoadingPreferenceConfig
-> Rep SessionLoadingPreferenceConfig x
from :: forall x.
SessionLoadingPreferenceConfig
-> Rep SessionLoadingPreferenceConfig x
$cto :: forall x.
Rep SessionLoadingPreferenceConfig x
-> SessionLoadingPreferenceConfig
to :: forall x.
Rep SessionLoadingPreferenceConfig x
-> SessionLoadingPreferenceConfig
Generic)

instance Pretty SessionLoadingPreferenceConfig where
    pretty :: forall ann. SessionLoadingPreferenceConfig -> Doc ann
pretty SessionLoadingPreferenceConfig
PreferSingleComponentLoading = Doc ann
"Prefer Single Component Loading"
    pretty SessionLoadingPreferenceConfig
PreferMultiComponentLoading  = Doc ann
"Prefer Multiple Components Loading"

instance ToJSON SessionLoadingPreferenceConfig where
    toJSON :: SessionLoadingPreferenceConfig -> Value
toJSON SessionLoadingPreferenceConfig
PreferSingleComponentLoading =
        Text -> Value
String Text
"singleComponent"
    toJSON SessionLoadingPreferenceConfig
PreferMultiComponentLoading =
        Text -> Value
String Text
"multipleComponents"

instance FromJSON SessionLoadingPreferenceConfig where
    parseJSON :: Value -> Parser SessionLoadingPreferenceConfig
parseJSON (String Text
val) = case Text
val of
        Text
"singleComponent"    -> SessionLoadingPreferenceConfig
-> Parser SessionLoadingPreferenceConfig
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SessionLoadingPreferenceConfig
PreferSingleComponentLoading
        Text
"multipleComponents" -> SessionLoadingPreferenceConfig
-> Parser SessionLoadingPreferenceConfig
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SessionLoadingPreferenceConfig
PreferMultiComponentLoading
        Text
_ -> String
-> Parser SessionLoadingPreferenceConfig
-> Parser SessionLoadingPreferenceConfig
forall a. String -> Parser a -> Parser a
A.prependFailure String
"parsing SessionLoadingPreferenceConfig failed, "
            (String -> Parser SessionLoadingPreferenceConfig
forall a. String -> Parser a
A.parseFail (String -> Parser SessionLoadingPreferenceConfig)
-> String -> Parser SessionLoadingPreferenceConfig
forall a b. (a -> b) -> a -> b
$ String
"Expected one of \"singleComponent\" or \"multipleComponents\" but got " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
val )
    parseJSON Value
o = String
-> Parser SessionLoadingPreferenceConfig
-> Parser SessionLoadingPreferenceConfig
forall a. String -> Parser a -> Parser a
A.prependFailure String
"parsing SessionLoadingPreferenceConfig failed, "
            (String -> Value -> Parser SessionLoadingPreferenceConfig
forall a. String -> Value -> Parser a
A.typeMismatch String
"String" Value
o)

-- | A PluginConfig is a generic configuration for a given HLS plugin.  It
-- provides a "big switch" to turn it on or off as a whole, as well as small
-- switches per feature, and a slot for custom config.
-- This provides a regular naming scheme for all plugin config.
data PluginConfig =
    PluginConfig
      { PluginConfig -> Bool
plcGlobalOn         :: !Bool
      , PluginConfig -> Bool
plcCallHierarchyOn  :: !Bool
      , PluginConfig -> Bool
plcCodeActionsOn    :: !Bool
      , PluginConfig -> Bool
plcCodeLensOn       :: !Bool
      , PluginConfig -> Bool
plcDiagnosticsOn    :: !Bool
      , PluginConfig -> Bool
plcHoverOn          :: !Bool
      , PluginConfig -> Bool
plcSymbolsOn        :: !Bool
      , PluginConfig -> Bool
plcCompletionOn     :: !Bool
      , PluginConfig -> Bool
plcRenameOn         :: !Bool
      , PluginConfig -> Bool
plcSelectionRangeOn :: !Bool
      , PluginConfig -> Bool
plcFoldingRangeOn   :: !Bool
      , PluginConfig -> Bool
plcSemanticTokensOn :: !Bool
      , PluginConfig -> Object
plcConfig           :: !Object
      } deriving (Int -> PluginConfig -> ShowS
[PluginConfig] -> ShowS
PluginConfig -> String
(Int -> PluginConfig -> ShowS)
-> (PluginConfig -> String)
-> ([PluginConfig] -> ShowS)
-> Show PluginConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PluginConfig -> ShowS
showsPrec :: Int -> PluginConfig -> ShowS
$cshow :: PluginConfig -> String
show :: PluginConfig -> String
$cshowList :: [PluginConfig] -> ShowS
showList :: [PluginConfig] -> ShowS
Show,PluginConfig -> PluginConfig -> Bool
(PluginConfig -> PluginConfig -> Bool)
-> (PluginConfig -> PluginConfig -> Bool) -> Eq PluginConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PluginConfig -> PluginConfig -> Bool
== :: PluginConfig -> PluginConfig -> Bool
$c/= :: PluginConfig -> PluginConfig -> Bool
/= :: PluginConfig -> PluginConfig -> Bool
Eq)

instance Default PluginConfig where
  def :: PluginConfig
def = PluginConfig
      { $sel:plcGlobalOn:PluginConfig :: Bool
plcGlobalOn         = Bool
True
      , $sel:plcCallHierarchyOn:PluginConfig :: Bool
plcCallHierarchyOn  = Bool
True
      , $sel:plcCodeActionsOn:PluginConfig :: Bool
plcCodeActionsOn    = Bool
True
      , $sel:plcCodeLensOn:PluginConfig :: Bool
plcCodeLensOn       = Bool
True
      , $sel:plcDiagnosticsOn:PluginConfig :: Bool
plcDiagnosticsOn    = Bool
True
      , $sel:plcHoverOn:PluginConfig :: Bool
plcHoverOn          = Bool
True
      , $sel:plcSymbolsOn:PluginConfig :: Bool
plcSymbolsOn        = Bool
True
      , $sel:plcCompletionOn:PluginConfig :: Bool
plcCompletionOn     = Bool
True
      , $sel:plcRenameOn:PluginConfig :: Bool
plcRenameOn         = Bool
True
      , $sel:plcSelectionRangeOn:PluginConfig :: Bool
plcSelectionRangeOn = Bool
True
      , $sel:plcFoldingRangeOn:PluginConfig :: Bool
plcFoldingRangeOn   = Bool
True
      , $sel:plcSemanticTokensOn:PluginConfig :: Bool
plcSemanticTokensOn = Bool
True
      , $sel:plcConfig:PluginConfig :: Object
plcConfig           = Object
forall a. Monoid a => a
mempty
      }

instance ToJSON PluginConfig where
    toJSON :: PluginConfig -> Value
toJSON (PluginConfig Bool
g Bool
ch Bool
ca Bool
cl Bool
d Bool
h Bool
s Bool
c Bool
rn Bool
sr Bool
fr Bool
st Object
cfg) = Value
r
      where
        r :: Value
r = [Pair] -> Value
object [ Key
"globalOn"         Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
g
                   , Key
"callHierarchyOn"  Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
ch
                   , Key
"codeActionsOn"    Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
ca
                   , Key
"codeLensOn"       Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
cl
                   , Key
"diagnosticsOn"    Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
d
                   , Key
"hoverOn"          Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
h
                   , Key
"symbolsOn"        Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
s
                   , Key
"completionOn"     Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
c
                   , Key
"renameOn"         Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
rn
                   , Key
"selectionRangeOn" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
sr
                   , Key
"foldingRangeOn"   Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
fr
                   , Key
"semanticTokensOn" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
st
                   , Key
"config"           Key -> Object -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Object
cfg
                   ]

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

data PluginDescriptor (ideState :: Type) =
  PluginDescriptor { forall ideState. PluginDescriptor ideState -> PluginId
pluginId           :: !PluginId
                   , forall ideState. PluginDescriptor ideState -> Text
pluginDescription  :: !T.Text
                   -- ^ Unique identifier of the plugin.
                   , forall ideState. PluginDescriptor ideState -> Natural
pluginPriority     :: Natural
                   -- ^ Plugin handlers are called in priority order, higher priority first
                   , forall ideState. PluginDescriptor ideState -> Rules ()
pluginRules        :: !(Rules ())
                   , forall ideState.
PluginDescriptor ideState -> [PluginCommand ideState]
pluginCommands     :: ![PluginCommand ideState]
                   , forall ideState.
PluginDescriptor ideState -> PluginHandlers ideState
pluginHandlers     :: PluginHandlers ideState
                   , forall ideState. PluginDescriptor ideState -> ConfigDescriptor
pluginConfigDescriptor :: ConfigDescriptor
                   , forall ideState.
PluginDescriptor ideState -> PluginNotificationHandlers ideState
pluginNotificationHandlers :: PluginNotificationHandlers ideState
                   , forall ideState. PluginDescriptor ideState -> DynFlagsModifications
pluginModifyDynflags :: DynFlagsModifications
                   , forall ideState.
PluginDescriptor ideState
-> Maybe (ParserInfo (IdeCommand ideState))
pluginCli            :: Maybe (ParserInfo (IdeCommand ideState))
                   , forall ideState. PluginDescriptor ideState -> [Text]
pluginFileType       :: [T.Text]
                   -- ^ File extension of the files the plugin is responsible for.
                   --   The plugin is only allowed to handle files with these extensions.
                   --   When writing handlers, etc. for this plugin it can be assumed that all handled files are of this type.
                   --   The file extension must have a leading '.'.
                   }

describePlugin :: PluginDescriptor c -> Doc ann
describePlugin :: forall c ann. PluginDescriptor c -> Doc ann
describePlugin PluginDescriptor c
p =
  let
    PluginId Text
pid = PluginDescriptor c -> PluginId
forall ideState. PluginDescriptor ideState -> PluginId
pluginId PluginDescriptor c
p
    pdesc :: Text
pdesc = PluginDescriptor c -> Text
forall ideState. PluginDescriptor ideState -> Text
pluginDescription PluginDescriptor c
p
  in Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
pid Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
4 (Doc ann
forall ann. Doc ann
PP.line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
pdesc)


-- | An existential wrapper of 'Properties'
data CustomConfig = forall r. CustomConfig (Properties r)

-- | Describes the configuration of a plugin.
-- A plugin may be configurable as can be seen below:
--
-- @
-- {
--  "plugin-id": {
--    "globalOn": true,
--    "codeActionsOn": true,
--    "codeLensOn": true,
--    "config": {
--      "property1": "foo"
--     }
--   }
-- }
-- @
--
-- @globalOn@, @codeActionsOn@, and @codeLensOn@ etc. are called generic configs
-- which can be inferred from handlers registered by the plugin.
-- @config@ is called custom config, which is defined using 'Properties'.
data ConfigDescriptor = ConfigDescriptor {
  -- | Initial values for the generic config
  ConfigDescriptor -> PluginConfig
configInitialGenericConfig :: PluginConfig,
  -- | Whether or not to generate @diagnosticsOn@ config.
  -- Diagnostics emit in arbitrary shake rules,
  -- so we can't know statically if the plugin produces diagnostics
  ConfigDescriptor -> Bool
configHasDiagnostics       :: Bool,
  -- | Custom config.
  ConfigDescriptor -> CustomConfig
configCustomConfig         :: CustomConfig
}

mkCustomConfig :: Properties r -> CustomConfig
mkCustomConfig :: forall (r :: [PropertyKey]). Properties r -> CustomConfig
mkCustomConfig = Properties r -> CustomConfig
forall (r :: [PropertyKey]). Properties r -> CustomConfig
CustomConfig

defaultConfigDescriptor :: ConfigDescriptor
defaultConfigDescriptor :: ConfigDescriptor
defaultConfigDescriptor =
    PluginConfig -> Bool -> CustomConfig -> ConfigDescriptor
ConfigDescriptor PluginConfig
forall a. Default a => a
Data.Default.def Bool
False (Properties '[] -> CustomConfig
forall (r :: [PropertyKey]). Properties r -> CustomConfig
mkCustomConfig Properties '[]
emptyProperties)

-- | Lookup the current config for a plugin
configForPlugin :: Config -> PluginDescriptor c -> PluginConfig
configForPlugin :: forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
config PluginDescriptor{Natural
[Text]
[PluginCommand c]
Maybe (ParserInfo (IdeCommand c))
Text
Rules ()
PluginId
PluginNotificationHandlers c
PluginHandlers c
ConfigDescriptor
DynFlagsModifications
$sel:pluginPriority:PluginDescriptor :: forall ideState. PluginDescriptor ideState -> Natural
$sel:pluginId:PluginDescriptor :: forall ideState. PluginDescriptor ideState -> PluginId
$sel:pluginCommands:PluginDescriptor :: forall ideState.
PluginDescriptor ideState -> [PluginCommand ideState]
pluginModifyDynflags :: forall ideState. PluginDescriptor ideState -> DynFlagsModifications
$sel:pluginDescription:PluginDescriptor :: forall ideState. PluginDescriptor ideState -> Text
$sel:pluginRules:PluginDescriptor :: forall ideState. PluginDescriptor ideState -> Rules ()
$sel:pluginHandlers:PluginDescriptor :: forall ideState.
PluginDescriptor ideState -> PluginHandlers ideState
$sel:pluginConfigDescriptor:PluginDescriptor :: forall ideState. PluginDescriptor ideState -> ConfigDescriptor
$sel:pluginNotificationHandlers:PluginDescriptor :: forall ideState.
PluginDescriptor ideState -> PluginNotificationHandlers ideState
$sel:pluginCli:PluginDescriptor :: forall ideState.
PluginDescriptor ideState
-> Maybe (ParserInfo (IdeCommand ideState))
$sel:pluginFileType:PluginDescriptor :: forall ideState. PluginDescriptor ideState -> [Text]
pluginId :: PluginId
pluginDescription :: Text
pluginPriority :: Natural
pluginRules :: Rules ()
pluginCommands :: [PluginCommand c]
pluginHandlers :: PluginHandlers c
pluginConfigDescriptor :: ConfigDescriptor
pluginNotificationHandlers :: PluginNotificationHandlers c
pluginModifyDynflags :: DynFlagsModifications
pluginCli :: Maybe (ParserInfo (IdeCommand c))
pluginFileType :: [Text]
..}
    = PluginConfig
-> PluginId -> Map PluginId PluginConfig -> PluginConfig
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (ConfigDescriptor -> PluginConfig
configInitialGenericConfig ConfigDescriptor
pluginConfigDescriptor) PluginId
pluginId (Config -> Map PluginId PluginConfig
plugins Config
config)

-- | Checks that a specific plugin is globally enabled in order to respond to
-- requests
pluginEnabledGlobally :: PluginDescriptor c -> Config -> HandleRequestResult
pluginEnabledGlobally :: forall c. PluginDescriptor c -> Config -> HandleRequestResult
pluginEnabledGlobally PluginDescriptor c
desc Config
conf = if PluginConfig -> Bool
plcGlobalOn (Config -> PluginDescriptor c -> PluginConfig
forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
conf PluginDescriptor c
desc)
                           then HandleRequestResult
HandlesRequest
                           else RejectionReason -> HandleRequestResult
DoesNotHandleRequest RejectionReason
DisabledGlobally

-- | Checks that a specific feature for a given plugin is enabled in order
-- to respond to requests
pluginFeatureEnabled :: (PluginConfig -> Bool) -> PluginDescriptor c -> Config -> HandleRequestResult
pluginFeatureEnabled :: forall c.
(PluginConfig -> Bool)
-> PluginDescriptor c -> Config -> HandleRequestResult
pluginFeatureEnabled PluginConfig -> Bool
f PluginDescriptor c
desc Config
conf = if PluginConfig -> Bool
f (Config -> PluginDescriptor c -> PluginConfig
forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
conf PluginDescriptor c
desc)
                                      then HandleRequestResult
HandlesRequest
                                      else RejectionReason -> HandleRequestResult
DoesNotHandleRequest RejectionReason
FeatureDisabled

-- |Determine whether this request should be routed to the plugin. Fails closed
-- if we can't determine which plugin it should be routed to.
pluginResolverResponsible :: L.HasData_ m (Maybe Value) => m -> PluginDescriptor c -> HandleRequestResult
pluginResolverResponsible :: forall m c.
HasData_ m (Maybe Value) =>
m -> PluginDescriptor c -> HandleRequestResult
pluginResolverResponsible
  (Getting (Maybe Value) m (Maybe Value) -> m -> Maybe Value
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Value) m (Maybe Value)
forall s a. HasData_ s a => Lens' s a
Lens' m (Maybe Value)
L.data_ -> (Just (Value -> Result PluginResolveData
forall a. FromJSON a => Value -> Result a
fromJSON -> (Success (PluginResolveData o :: PluginId
o@(PluginId Text
ot) Uri
_ Value
_)))))
  PluginDescriptor c
pluginDesc =
  if PluginDescriptor c -> PluginId
forall ideState. PluginDescriptor ideState -> PluginId
pluginId PluginDescriptor c
pluginDesc PluginId -> PluginId -> Bool
forall a. Eq a => a -> a -> Bool
== PluginId
o
    then HandleRequestResult
HandlesRequest
    else RejectionReason -> HandleRequestResult
DoesNotHandleRequest (RejectionReason -> HandleRequestResult)
-> RejectionReason -> HandleRequestResult
forall a b. (a -> b) -> a -> b
$ Text -> RejectionReason
NotResolveOwner Text
ot
-- If we can't determine who this request belongs to, then we don't want any plugin
-- to handle it.
pluginResolverResponsible m
_ PluginDescriptor c
_ = RejectionReason -> HandleRequestResult
DoesNotHandleRequest (RejectionReason -> HandleRequestResult)
-> RejectionReason -> HandleRequestResult
forall a b. (a -> b) -> a -> b
$ Text -> RejectionReason
NotResolveOwner Text
"(unable to determine resolve owner)"

-- | Check whether the given plugin descriptor supports the file with
-- the given path. Compares the file extension from the msgParams with the
-- file extension the plugin is responsible for.
-- We are passing the msgParams here even though we only need the URI URI here.
-- If in the future we need to be able to provide only an URI it can be
-- separated again.
pluginSupportsFileType :: (L.HasTextDocument m doc, L.HasUri doc Uri) => m -> PluginDescriptor c -> HandleRequestResult
pluginSupportsFileType :: forall m doc c.
(HasTextDocument m doc, HasUri doc Uri) =>
m -> PluginDescriptor c -> HandleRequestResult
pluginSupportsFileType m
msgParams PluginDescriptor c
pluginDesc =
  case Maybe String
mfp of
    Just String
fp | String -> Text
T.pack (ShowS
takeExtension String
fp) Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` PluginDescriptor c -> [Text]
forall ideState. PluginDescriptor ideState -> [Text]
pluginFileType PluginDescriptor c
pluginDesc -> HandleRequestResult
HandlesRequest
    Maybe String
_ -> RejectionReason -> HandleRequestResult
DoesNotHandleRequest (RejectionReason -> HandleRequestResult)
-> RejectionReason -> HandleRequestResult
forall a b. (a -> b) -> a -> b
$ Text -> RejectionReason
DoesNotSupportFileType (Text -> (String -> Text) -> Maybe String -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"(unable to determine file type)" (String -> Text
T.pack (String -> Text) -> ShowS -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
takeExtension) Maybe String
mfp)
    where
      mfp :: Maybe String
mfp = Uri -> Maybe String
uriToFilePath Uri
uri
      uri :: Uri
uri = m
msgParams m -> Getting Uri m Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (doc -> Const Uri doc) -> m -> Const Uri m
forall s a. HasTextDocument s a => Lens' s a
Lens' m doc
L.textDocument ((doc -> Const Uri doc) -> m -> Const Uri m)
-> ((Uri -> Const Uri Uri) -> doc -> Const Uri doc)
-> Getting Uri m Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri) -> doc -> Const Uri doc
forall s a. HasUri s a => Lens' s a
Lens' doc Uri
L.uri

-- | Methods that can be handled by plugins.
-- 'ExtraParams' captures any extra data the IDE passes to the handlers for this method
-- Only methods for which we know how to combine responses can be instances of 'PluginMethod'
class HasTracing (MessageParams m) => PluginMethod (k :: MessageKind) (m :: Method ClientToServer k) where

  -- | Parse the configuration to check if this plugin is globally enabled, and
  -- if the feature which handles this method is enabled. Perform sanity checks
  -- on the message to see whether the plugin handles this message in particular.
  -- This class is only used to determine whether a plugin can handle a specific
  -- request. Commands and rules do not use this logic to determine whether or
  -- not they are run.
  --
  --
  -- A common reason why a plugin won't handle a request even though it is enabled:
  --   * The plugin cannot handle requests associated with the specific URI
  --     * Since the implementation of [cabal plugins](https://github.com/haskell/haskell-language-server/issues/2940)
  --       HLS knows plugins specific to Haskell and specific to [Cabal file descriptions](https://cabal.readthedocs.io/en/3.6/cabal-package.html)
  --   * The resolve request is not routed to that specific plugin. Each resolve
  --     request needs to be routed to only one plugin.
  --
  -- Strictly speaking, we are conflating two concepts here:
  --   * Dynamically enabled (e.g. on a per-message basis)
  --   * Statically enabled (e.g. by configuration in the lsp-client)
  --     * Strictly speaking, this might also change dynamically
  --
  -- But there is no use to split it up into two different methods for now.
  handlesRequest
    :: SMethod m
    -- ^ Method type.
    -> MessageParams m
    -- ^ Whether a plugin is enabled might depend on the message parameters
    --   e.g. 'pluginFileType' specifies which file extensions a plugin is allowed to handle
    -> PluginDescriptor c
    -- ^ Contains meta information such as PluginId and which file types this
    -- plugin is able to handle.
    -> Config
    -- ^ Generic config description, expected to contain 'PluginConfig' configuration
    -- for this plugin
    -> HandleRequestResult
    -- ^ Is this plugin enabled and allowed to respond to the given request
    -- with the given parameters?

  default handlesRequest :: (L.HasTextDocument (MessageParams m) doc, L.HasUri doc Uri)
                              => SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> HandleRequestResult
  handlesRequest SMethod m
_ MessageParams m
params PluginDescriptor c
desc Config
conf =
    PluginDescriptor c -> Config -> HandleRequestResult
forall c. PluginDescriptor c -> Config -> HandleRequestResult
pluginEnabledGlobally PluginDescriptor c
desc Config
conf HandleRequestResult -> HandleRequestResult -> HandleRequestResult
forall a. Semigroup a => a -> a -> a
<> MessageParams m -> PluginDescriptor c -> HandleRequestResult
forall m doc c.
(HasTextDocument m doc, HasUri doc Uri) =>
m -> PluginDescriptor c -> HandleRequestResult
pluginSupportsFileType MessageParams m
params PluginDescriptor c
desc

-- | Check if a plugin is enabled, if one of it's specific config's is enabled,
-- and if it supports the file
pluginEnabledWithFeature :: (L.HasTextDocument (MessageParams m) doc, L.HasUri doc Uri)
                              => (PluginConfig -> Bool) -> SMethod m -> MessageParams m
                              -> PluginDescriptor c -> Config -> HandleRequestResult
pluginEnabledWithFeature :: forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       doc c.
(HasTextDocument (MessageParams m) doc, HasUri doc Uri) =>
(PluginConfig -> Bool)
-> SMethod m
-> MessageParams m
-> PluginDescriptor c
-> Config
-> HandleRequestResult
pluginEnabledWithFeature PluginConfig -> Bool
feature SMethod m
_ MessageParams m
msgParams PluginDescriptor c
pluginDesc Config
config =
  PluginDescriptor c -> Config -> HandleRequestResult
forall c. PluginDescriptor c -> Config -> HandleRequestResult
pluginEnabledGlobally PluginDescriptor c
pluginDesc Config
config
  HandleRequestResult -> HandleRequestResult -> HandleRequestResult
forall a. Semigroup a => a -> a -> a
<> (PluginConfig -> Bool)
-> PluginDescriptor c -> Config -> HandleRequestResult
forall c.
(PluginConfig -> Bool)
-> PluginDescriptor c -> Config -> HandleRequestResult
pluginFeatureEnabled PluginConfig -> Bool
feature PluginDescriptor c
pluginDesc Config
config
  HandleRequestResult -> HandleRequestResult -> HandleRequestResult
forall a. Semigroup a => a -> a -> a
<> MessageParams m -> PluginDescriptor c -> HandleRequestResult
forall m doc c.
(HasTextDocument m doc, HasUri doc Uri) =>
m -> PluginDescriptor c -> HandleRequestResult
pluginSupportsFileType MessageParams m
msgParams PluginDescriptor c
pluginDesc

-- | Check if a plugin is enabled, if one of it's specific configs is enabled,
-- and if it's the plugin responsible for a resolve request.
pluginEnabledResolve :: L.HasData_ s (Maybe Value) => (PluginConfig -> Bool) -> p -> s -> PluginDescriptor c -> Config -> HandleRequestResult
pluginEnabledResolve :: forall s p c.
HasData_ s (Maybe Value) =>
(PluginConfig -> Bool)
-> p -> s -> PluginDescriptor c -> Config -> HandleRequestResult
pluginEnabledResolve PluginConfig -> Bool
feature p
_ s
msgParams PluginDescriptor c
pluginDesc Config
config =
    PluginDescriptor c -> Config -> HandleRequestResult
forall c. PluginDescriptor c -> Config -> HandleRequestResult
pluginEnabledGlobally PluginDescriptor c
pluginDesc Config
config
    HandleRequestResult -> HandleRequestResult -> HandleRequestResult
forall a. Semigroup a => a -> a -> a
<> (PluginConfig -> Bool)
-> PluginDescriptor c -> Config -> HandleRequestResult
forall c.
(PluginConfig -> Bool)
-> PluginDescriptor c -> Config -> HandleRequestResult
pluginFeatureEnabled PluginConfig -> Bool
feature PluginDescriptor c
pluginDesc Config
config
    HandleRequestResult -> HandleRequestResult -> HandleRequestResult
forall a. Semigroup a => a -> a -> a
<> s -> PluginDescriptor c -> HandleRequestResult
forall m c.
HasData_ m (Maybe Value) =>
m -> PluginDescriptor c -> HandleRequestResult
pluginResolverResponsible s
msgParams PluginDescriptor c
pluginDesc

instance PluginMethod Request Method_TextDocumentCodeAction where
  handlesRequest :: forall c.
SMethod 'Method_TextDocumentCodeAction
-> MessageParams 'Method_TextDocumentCodeAction
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest = (PluginConfig -> Bool)
-> SMethod 'Method_TextDocumentCodeAction
-> MessageParams 'Method_TextDocumentCodeAction
-> PluginDescriptor c
-> Config
-> HandleRequestResult
forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       doc c.
(HasTextDocument (MessageParams m) doc, HasUri doc Uri) =>
(PluginConfig -> Bool)
-> SMethod m
-> MessageParams m
-> PluginDescriptor c
-> Config
-> HandleRequestResult
pluginEnabledWithFeature PluginConfig -> Bool
plcCodeActionsOn

instance PluginMethod Request Method_CodeActionResolve where
  -- See Note [Resolve in PluginHandlers]
  handlesRequest :: forall c.
SMethod 'Method_CodeActionResolve
-> MessageParams 'Method_CodeActionResolve
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest = (PluginConfig -> Bool)
-> SMethod 'Method_CodeActionResolve
-> CodeAction
-> PluginDescriptor c
-> Config
-> HandleRequestResult
forall s p c.
HasData_ s (Maybe Value) =>
(PluginConfig -> Bool)
-> p -> s -> PluginDescriptor c -> Config -> HandleRequestResult
pluginEnabledResolve PluginConfig -> Bool
plcCodeActionsOn

instance PluginMethod Request Method_TextDocumentDefinition where
  handlesRequest :: forall c.
SMethod 'Method_TextDocumentDefinition
-> MessageParams 'Method_TextDocumentDefinition
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest SMethod 'Method_TextDocumentDefinition
_ MessageParams 'Method_TextDocumentDefinition
msgParams PluginDescriptor c
pluginDesc Config
_ = DefinitionParams -> PluginDescriptor c -> HandleRequestResult
forall m doc c.
(HasTextDocument m doc, HasUri doc Uri) =>
m -> PluginDescriptor c -> HandleRequestResult
pluginSupportsFileType MessageParams 'Method_TextDocumentDefinition
DefinitionParams
msgParams PluginDescriptor c
pluginDesc

instance PluginMethod Request Method_TextDocumentTypeDefinition where
  handlesRequest :: forall c.
SMethod 'Method_TextDocumentTypeDefinition
-> MessageParams 'Method_TextDocumentTypeDefinition
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest SMethod 'Method_TextDocumentTypeDefinition
_ MessageParams 'Method_TextDocumentTypeDefinition
msgParams PluginDescriptor c
pluginDesc Config
_ = TypeDefinitionParams -> PluginDescriptor c -> HandleRequestResult
forall m doc c.
(HasTextDocument m doc, HasUri doc Uri) =>
m -> PluginDescriptor c -> HandleRequestResult
pluginSupportsFileType MessageParams 'Method_TextDocumentTypeDefinition
TypeDefinitionParams
msgParams PluginDescriptor c
pluginDesc

instance PluginMethod Request Method_TextDocumentDocumentHighlight where
  handlesRequest :: forall c.
SMethod 'Method_TextDocumentDocumentHighlight
-> MessageParams 'Method_TextDocumentDocumentHighlight
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest SMethod 'Method_TextDocumentDocumentHighlight
_ MessageParams 'Method_TextDocumentDocumentHighlight
msgParams PluginDescriptor c
pluginDesc Config
_ = DocumentHighlightParams
-> PluginDescriptor c -> HandleRequestResult
forall m doc c.
(HasTextDocument m doc, HasUri doc Uri) =>
m -> PluginDescriptor c -> HandleRequestResult
pluginSupportsFileType MessageParams 'Method_TextDocumentDocumentHighlight
DocumentHighlightParams
msgParams PluginDescriptor c
pluginDesc

instance PluginMethod Request Method_TextDocumentReferences where
  handlesRequest :: forall c.
SMethod 'Method_TextDocumentReferences
-> MessageParams 'Method_TextDocumentReferences
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest SMethod 'Method_TextDocumentReferences
_ MessageParams 'Method_TextDocumentReferences
msgParams PluginDescriptor c
pluginDesc Config
_ = ReferenceParams -> PluginDescriptor c -> HandleRequestResult
forall m doc c.
(HasTextDocument m doc, HasUri doc Uri) =>
m -> PluginDescriptor c -> HandleRequestResult
pluginSupportsFileType MessageParams 'Method_TextDocumentReferences
ReferenceParams
msgParams PluginDescriptor c
pluginDesc

instance PluginMethod Request Method_WorkspaceSymbol where
  -- Unconditionally enabled, but should it really be?
  handlesRequest :: forall c.
SMethod 'Method_WorkspaceSymbol
-> MessageParams 'Method_WorkspaceSymbol
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest SMethod 'Method_WorkspaceSymbol
_ MessageParams 'Method_WorkspaceSymbol
_ PluginDescriptor c
_ Config
_ = HandleRequestResult
HandlesRequest

instance PluginMethod Request Method_TextDocumentCodeLens where
  handlesRequest :: forall c.
SMethod 'Method_TextDocumentCodeLens
-> MessageParams 'Method_TextDocumentCodeLens
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest = (PluginConfig -> Bool)
-> SMethod 'Method_TextDocumentCodeLens
-> MessageParams 'Method_TextDocumentCodeLens
-> PluginDescriptor c
-> Config
-> HandleRequestResult
forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       doc c.
(HasTextDocument (MessageParams m) doc, HasUri doc Uri) =>
(PluginConfig -> Bool)
-> SMethod m
-> MessageParams m
-> PluginDescriptor c
-> Config
-> HandleRequestResult
pluginEnabledWithFeature PluginConfig -> Bool
plcCodeLensOn

instance PluginMethod Request Method_CodeLensResolve where
  -- See Note [Resolve in PluginHandlers]
  handlesRequest :: forall c.
SMethod 'Method_CodeLensResolve
-> MessageParams 'Method_CodeLensResolve
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest = (PluginConfig -> Bool)
-> SMethod 'Method_CodeLensResolve
-> CodeLens
-> PluginDescriptor c
-> Config
-> HandleRequestResult
forall s p c.
HasData_ s (Maybe Value) =>
(PluginConfig -> Bool)
-> p -> s -> PluginDescriptor c -> Config -> HandleRequestResult
pluginEnabledResolve PluginConfig -> Bool
plcCodeLensOn

instance PluginMethod Request Method_TextDocumentRename where
  handlesRequest :: forall c.
SMethod 'Method_TextDocumentRename
-> MessageParams 'Method_TextDocumentRename
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest = (PluginConfig -> Bool)
-> SMethod 'Method_TextDocumentRename
-> MessageParams 'Method_TextDocumentRename
-> PluginDescriptor c
-> Config
-> HandleRequestResult
forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       doc c.
(HasTextDocument (MessageParams m) doc, HasUri doc Uri) =>
(PluginConfig -> Bool)
-> SMethod m
-> MessageParams m
-> PluginDescriptor c
-> Config
-> HandleRequestResult
pluginEnabledWithFeature PluginConfig -> Bool
plcRenameOn

instance PluginMethod Request Method_TextDocumentPrepareRename where
  handlesRequest :: forall c.
SMethod 'Method_TextDocumentPrepareRename
-> MessageParams 'Method_TextDocumentPrepareRename
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest = (PluginConfig -> Bool)
-> SMethod 'Method_TextDocumentPrepareRename
-> MessageParams 'Method_TextDocumentPrepareRename
-> PluginDescriptor c
-> Config
-> HandleRequestResult
forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       doc c.
(HasTextDocument (MessageParams m) doc, HasUri doc Uri) =>
(PluginConfig -> Bool)
-> SMethod m
-> MessageParams m
-> PluginDescriptor c
-> Config
-> HandleRequestResult
pluginEnabledWithFeature PluginConfig -> Bool
plcRenameOn

instance PluginMethod Request Method_TextDocumentHover where
  handlesRequest :: forall c.
SMethod 'Method_TextDocumentHover
-> MessageParams 'Method_TextDocumentHover
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest = (PluginConfig -> Bool)
-> SMethod 'Method_TextDocumentHover
-> MessageParams 'Method_TextDocumentHover
-> PluginDescriptor c
-> Config
-> HandleRequestResult
forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       doc c.
(HasTextDocument (MessageParams m) doc, HasUri doc Uri) =>
(PluginConfig -> Bool)
-> SMethod m
-> MessageParams m
-> PluginDescriptor c
-> Config
-> HandleRequestResult
pluginEnabledWithFeature PluginConfig -> Bool
plcHoverOn

instance PluginMethod Request Method_TextDocumentDocumentSymbol where
  handlesRequest :: forall c.
SMethod 'Method_TextDocumentDocumentSymbol
-> MessageParams 'Method_TextDocumentDocumentSymbol
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest = (PluginConfig -> Bool)
-> SMethod 'Method_TextDocumentDocumentSymbol
-> MessageParams 'Method_TextDocumentDocumentSymbol
-> PluginDescriptor c
-> Config
-> HandleRequestResult
forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       doc c.
(HasTextDocument (MessageParams m) doc, HasUri doc Uri) =>
(PluginConfig -> Bool)
-> SMethod m
-> MessageParams m
-> PluginDescriptor c
-> Config
-> HandleRequestResult
pluginEnabledWithFeature PluginConfig -> Bool
plcSymbolsOn

instance PluginMethod Request Method_CompletionItemResolve where
  -- See Note [Resolve in PluginHandlers]
  handlesRequest :: forall c.
SMethod 'Method_CompletionItemResolve
-> MessageParams 'Method_CompletionItemResolve
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest = (PluginConfig -> Bool)
-> SMethod 'Method_CompletionItemResolve
-> CompletionItem
-> PluginDescriptor c
-> Config
-> HandleRequestResult
forall s p c.
HasData_ s (Maybe Value) =>
(PluginConfig -> Bool)
-> p -> s -> PluginDescriptor c -> Config -> HandleRequestResult
pluginEnabledResolve PluginConfig -> Bool
plcCompletionOn

instance PluginMethod Request Method_TextDocumentCompletion where
  handlesRequest :: forall c.
SMethod 'Method_TextDocumentCompletion
-> MessageParams 'Method_TextDocumentCompletion
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest = (PluginConfig -> Bool)
-> SMethod 'Method_TextDocumentCompletion
-> MessageParams 'Method_TextDocumentCompletion
-> PluginDescriptor c
-> Config
-> HandleRequestResult
forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       doc c.
(HasTextDocument (MessageParams m) doc, HasUri doc Uri) =>
(PluginConfig -> Bool)
-> SMethod m
-> MessageParams m
-> PluginDescriptor c
-> Config
-> HandleRequestResult
pluginEnabledWithFeature PluginConfig -> Bool
plcCompletionOn

instance PluginMethod Request Method_TextDocumentFormatting where
  handlesRequest :: forall c.
SMethod 'Method_TextDocumentFormatting
-> MessageParams 'Method_TextDocumentFormatting
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest SMethod 'Method_TextDocumentFormatting
_ MessageParams 'Method_TextDocumentFormatting
msgParams PluginDescriptor c
pluginDesc Config
conf =
    (if Text -> PluginId
PluginId (Config -> Text
formattingProvider Config
conf) PluginId -> PluginId -> Bool
forall a. Eq a => a -> a -> Bool
== PluginId
pid
          Bool -> Bool -> Bool
|| Text -> PluginId
PluginId (Config -> Text
cabalFormattingProvider Config
conf) PluginId -> PluginId -> Bool
forall a. Eq a => a -> a -> Bool
== PluginId
pid
        then HandleRequestResult
HandlesRequest
        else RejectionReason -> HandleRequestResult
DoesNotHandleRequest (Text -> RejectionReason
NotFormattingProvider (Config -> Text
formattingProvider Config
conf)) )
    HandleRequestResult -> HandleRequestResult -> HandleRequestResult
forall a. Semigroup a => a -> a -> a
<> DocumentFormattingParams
-> PluginDescriptor c -> HandleRequestResult
forall m doc c.
(HasTextDocument m doc, HasUri doc Uri) =>
m -> PluginDescriptor c -> HandleRequestResult
pluginSupportsFileType MessageParams 'Method_TextDocumentFormatting
DocumentFormattingParams
msgParams PluginDescriptor c
pluginDesc
    where
      pid :: PluginId
pid = PluginDescriptor c -> PluginId
forall ideState. PluginDescriptor ideState -> PluginId
pluginId PluginDescriptor c
pluginDesc

instance PluginMethod Request Method_TextDocumentRangeFormatting where
  handlesRequest :: forall c.
SMethod 'Method_TextDocumentRangeFormatting
-> MessageParams 'Method_TextDocumentRangeFormatting
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest SMethod 'Method_TextDocumentRangeFormatting
_ MessageParams 'Method_TextDocumentRangeFormatting
msgParams PluginDescriptor c
pluginDesc Config
conf =
    (if Text -> PluginId
PluginId (Config -> Text
formattingProvider Config
conf) PluginId -> PluginId -> Bool
forall a. Eq a => a -> a -> Bool
== PluginId
pid
          Bool -> Bool -> Bool
|| Text -> PluginId
PluginId (Config -> Text
cabalFormattingProvider Config
conf) PluginId -> PluginId -> Bool
forall a. Eq a => a -> a -> Bool
== PluginId
pid
        then HandleRequestResult
HandlesRequest
        else RejectionReason -> HandleRequestResult
DoesNotHandleRequest (Text -> RejectionReason
NotFormattingProvider (Config -> Text
formattingProvider Config
conf)))
    HandleRequestResult -> HandleRequestResult -> HandleRequestResult
forall a. Semigroup a => a -> a -> a
<> DocumentRangeFormattingParams
-> PluginDescriptor c -> HandleRequestResult
forall m doc c.
(HasTextDocument m doc, HasUri doc Uri) =>
m -> PluginDescriptor c -> HandleRequestResult
pluginSupportsFileType MessageParams 'Method_TextDocumentRangeFormatting
DocumentRangeFormattingParams
msgParams PluginDescriptor c
pluginDesc
    where
      pid :: PluginId
pid = PluginDescriptor c -> PluginId
forall ideState. PluginDescriptor ideState -> PluginId
pluginId PluginDescriptor c
pluginDesc

instance PluginMethod Request Method_TextDocumentSemanticTokensFull where
  handlesRequest :: forall c.
SMethod 'Method_TextDocumentSemanticTokensFull
-> MessageParams 'Method_TextDocumentSemanticTokensFull
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest = (PluginConfig -> Bool)
-> SMethod 'Method_TextDocumentSemanticTokensFull
-> MessageParams 'Method_TextDocumentSemanticTokensFull
-> PluginDescriptor c
-> Config
-> HandleRequestResult
forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       doc c.
(HasTextDocument (MessageParams m) doc, HasUri doc Uri) =>
(PluginConfig -> Bool)
-> SMethod m
-> MessageParams m
-> PluginDescriptor c
-> Config
-> HandleRequestResult
pluginEnabledWithFeature PluginConfig -> Bool
plcSemanticTokensOn

instance PluginMethod Request Method_TextDocumentSemanticTokensFullDelta where
  handlesRequest :: forall c.
SMethod 'Method_TextDocumentSemanticTokensFullDelta
-> MessageParams 'Method_TextDocumentSemanticTokensFullDelta
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest = (PluginConfig -> Bool)
-> SMethod 'Method_TextDocumentSemanticTokensFullDelta
-> MessageParams 'Method_TextDocumentSemanticTokensFullDelta
-> PluginDescriptor c
-> Config
-> HandleRequestResult
forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       doc c.
(HasTextDocument (MessageParams m) doc, HasUri doc Uri) =>
(PluginConfig -> Bool)
-> SMethod m
-> MessageParams m
-> PluginDescriptor c
-> Config
-> HandleRequestResult
pluginEnabledWithFeature PluginConfig -> Bool
plcSemanticTokensOn

instance PluginMethod Request Method_TextDocumentPrepareCallHierarchy where
  handlesRequest :: forall c.
SMethod 'Method_TextDocumentPrepareCallHierarchy
-> MessageParams 'Method_TextDocumentPrepareCallHierarchy
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest = (PluginConfig -> Bool)
-> SMethod 'Method_TextDocumentPrepareCallHierarchy
-> MessageParams 'Method_TextDocumentPrepareCallHierarchy
-> PluginDescriptor c
-> Config
-> HandleRequestResult
forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       doc c.
(HasTextDocument (MessageParams m) doc, HasUri doc Uri) =>
(PluginConfig -> Bool)
-> SMethod m
-> MessageParams m
-> PluginDescriptor c
-> Config
-> HandleRequestResult
pluginEnabledWithFeature PluginConfig -> Bool
plcCallHierarchyOn

instance PluginMethod Request Method_TextDocumentSelectionRange where
  handlesRequest :: forall c.
SMethod 'Method_TextDocumentSelectionRange
-> MessageParams 'Method_TextDocumentSelectionRange
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest = (PluginConfig -> Bool)
-> SMethod 'Method_TextDocumentSelectionRange
-> MessageParams 'Method_TextDocumentSelectionRange
-> PluginDescriptor c
-> Config
-> HandleRequestResult
forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       doc c.
(HasTextDocument (MessageParams m) doc, HasUri doc Uri) =>
(PluginConfig -> Bool)
-> SMethod m
-> MessageParams m
-> PluginDescriptor c
-> Config
-> HandleRequestResult
pluginEnabledWithFeature PluginConfig -> Bool
plcSelectionRangeOn

instance PluginMethod Request Method_TextDocumentFoldingRange where
  handlesRequest :: forall c.
SMethod 'Method_TextDocumentFoldingRange
-> MessageParams 'Method_TextDocumentFoldingRange
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest = (PluginConfig -> Bool)
-> SMethod 'Method_TextDocumentFoldingRange
-> MessageParams 'Method_TextDocumentFoldingRange
-> PluginDescriptor c
-> Config
-> HandleRequestResult
forall {f :: MessageDirection} {t :: MessageKind} (m :: Method f t)
       doc c.
(HasTextDocument (MessageParams m) doc, HasUri doc Uri) =>
(PluginConfig -> Bool)
-> SMethod m
-> MessageParams m
-> PluginDescriptor c
-> Config
-> HandleRequestResult
pluginEnabledWithFeature PluginConfig -> Bool
plcFoldingRangeOn

instance PluginMethod Request Method_CallHierarchyIncomingCalls where
  -- This method has no URI parameter, thus no call to 'pluginResponsible'
  handlesRequest :: forall c.
SMethod 'Method_CallHierarchyIncomingCalls
-> MessageParams 'Method_CallHierarchyIncomingCalls
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest SMethod 'Method_CallHierarchyIncomingCalls
_ MessageParams 'Method_CallHierarchyIncomingCalls
_ PluginDescriptor c
pluginDesc Config
conf =
      PluginDescriptor c -> Config -> HandleRequestResult
forall c. PluginDescriptor c -> Config -> HandleRequestResult
pluginEnabledGlobally PluginDescriptor c
pluginDesc Config
conf
    HandleRequestResult -> HandleRequestResult -> HandleRequestResult
forall a. Semigroup a => a -> a -> a
<> (PluginConfig -> Bool)
-> PluginDescriptor c -> Config -> HandleRequestResult
forall c.
(PluginConfig -> Bool)
-> PluginDescriptor c -> Config -> HandleRequestResult
pluginFeatureEnabled PluginConfig -> Bool
plcCallHierarchyOn PluginDescriptor c
pluginDesc Config
conf

instance PluginMethod Request Method_CallHierarchyOutgoingCalls where
  -- This method has no URI parameter, thus no call to 'pluginResponsible'
  handlesRequest :: forall c.
SMethod 'Method_CallHierarchyOutgoingCalls
-> MessageParams 'Method_CallHierarchyOutgoingCalls
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest SMethod 'Method_CallHierarchyOutgoingCalls
_ MessageParams 'Method_CallHierarchyOutgoingCalls
_ PluginDescriptor c
pluginDesc Config
conf =
      PluginDescriptor c -> Config -> HandleRequestResult
forall c. PluginDescriptor c -> Config -> HandleRequestResult
pluginEnabledGlobally PluginDescriptor c
pluginDesc Config
conf
    HandleRequestResult -> HandleRequestResult -> HandleRequestResult
forall a. Semigroup a => a -> a -> a
<> (PluginConfig -> Bool)
-> PluginDescriptor c -> Config -> HandleRequestResult
forall c.
(PluginConfig -> Bool)
-> PluginDescriptor c -> Config -> HandleRequestResult
pluginFeatureEnabled PluginConfig -> Bool
plcCallHierarchyOn PluginDescriptor c
pluginDesc Config
conf

instance PluginMethod Request Method_WorkspaceExecuteCommand where
  handlesRequest :: forall c.
SMethod 'Method_WorkspaceExecuteCommand
-> MessageParams 'Method_WorkspaceExecuteCommand
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest SMethod 'Method_WorkspaceExecuteCommand
_ MessageParams 'Method_WorkspaceExecuteCommand
_ PluginDescriptor c
_ Config
_= HandleRequestResult
HandlesRequest

instance PluginMethod Request (Method_CustomMethod m) where
  handlesRequest :: forall c.
SMethod ('Method_CustomMethod m)
-> MessageParams ('Method_CustomMethod m)
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest SMethod ('Method_CustomMethod m)
_ MessageParams ('Method_CustomMethod m)
_ PluginDescriptor c
_ Config
_ = HandleRequestResult
HandlesRequest

-- Plugin Notifications

instance PluginMethod Notification Method_TextDocumentDidOpen where

instance PluginMethod Notification Method_TextDocumentDidChange where

instance PluginMethod Notification Method_TextDocumentDidSave where

instance PluginMethod Notification Method_TextDocumentDidClose where

instance PluginMethod Notification Method_WorkspaceDidChangeWatchedFiles where
  -- This method has no URI parameter, thus no call to 'pluginResponsible'.
  handlesRequest :: forall c.
SMethod 'Method_WorkspaceDidChangeWatchedFiles
-> MessageParams 'Method_WorkspaceDidChangeWatchedFiles
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest SMethod 'Method_WorkspaceDidChangeWatchedFiles
_ MessageParams 'Method_WorkspaceDidChangeWatchedFiles
_ PluginDescriptor c
desc Config
conf = PluginDescriptor c -> Config -> HandleRequestResult
forall c. PluginDescriptor c -> Config -> HandleRequestResult
pluginEnabledGlobally PluginDescriptor c
desc Config
conf

instance PluginMethod Notification Method_WorkspaceDidChangeWorkspaceFolders where
  -- This method has no URI parameter, thus no call to 'pluginResponsible'.
  handlesRequest :: forall c.
SMethod 'Method_WorkspaceDidChangeWorkspaceFolders
-> MessageParams 'Method_WorkspaceDidChangeWorkspaceFolders
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest SMethod 'Method_WorkspaceDidChangeWorkspaceFolders
_ MessageParams 'Method_WorkspaceDidChangeWorkspaceFolders
_ PluginDescriptor c
desc Config
conf = PluginDescriptor c -> Config -> HandleRequestResult
forall c. PluginDescriptor c -> Config -> HandleRequestResult
pluginEnabledGlobally PluginDescriptor c
desc Config
conf

instance PluginMethod Notification Method_WorkspaceDidChangeConfiguration where
  -- This method has no URI parameter, thus no call to 'pluginResponsible'.
  handlesRequest :: forall c.
SMethod 'Method_WorkspaceDidChangeConfiguration
-> MessageParams 'Method_WorkspaceDidChangeConfiguration
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest SMethod 'Method_WorkspaceDidChangeConfiguration
_ MessageParams 'Method_WorkspaceDidChangeConfiguration
_ PluginDescriptor c
desc Config
conf = PluginDescriptor c -> Config -> HandleRequestResult
forall c. PluginDescriptor c -> Config -> HandleRequestResult
pluginEnabledGlobally PluginDescriptor c
desc Config
conf

instance PluginMethod Notification Method_Initialized where
  -- This method has no URI parameter, thus no call to 'pluginResponsible'.
  handlesRequest :: forall c.
SMethod 'Method_Initialized
-> MessageParams 'Method_Initialized
-> PluginDescriptor c
-> Config
-> HandleRequestResult
handlesRequest SMethod 'Method_Initialized
_ MessageParams 'Method_Initialized
_ PluginDescriptor c
desc Config
conf = PluginDescriptor c -> Config -> HandleRequestResult
forall c. PluginDescriptor c -> Config -> HandleRequestResult
pluginEnabledGlobally PluginDescriptor c
desc Config
conf


-- ---------------------------------------------------------------------
-- Plugin Requests
-- ---------------------------------------------------------------------

class PluginMethod Request m => PluginRequestMethod (m :: Method ClientToServer Request) where
  -- | How to combine responses from different plugins.
  --
  -- For example, for Hover requests, we might have multiple producers of
  -- Hover information. We do not want to decide which one to display to the user
  -- but instead allow to define how to merge two hover request responses into one
  -- glorious hover box.
  --
  -- However, as sometimes only one handler of a request can realistically exist
  -- (such as TextDocumentFormatting), it is safe to just unconditionally report
  -- back one arbitrary result (arbitrary since it should only be one anyway).
  combineResponses
    :: SMethod m
    -> Config -- ^ IDE Configuration
    -> ClientCapabilities
    -> MessageParams m
    -> NonEmpty (MessageResult m) -> MessageResult m

  default combineResponses :: Semigroup (MessageResult m)
    => SMethod m -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (MessageResult m) -> MessageResult m
  combineResponses SMethod m
_method Config
_config ClientCapabilities
_caps MessageParams m
_params = NonEmpty (MessageResult m) -> MessageResult m
forall a. Semigroup a => NonEmpty a -> a
sconcat



---
instance PluginRequestMethod Method_TextDocumentCodeAction where
  combineResponses :: SMethod 'Method_TextDocumentCodeAction
-> Config
-> ClientCapabilities
-> MessageParams 'Method_TextDocumentCodeAction
-> NonEmpty (MessageResult 'Method_TextDocumentCodeAction)
-> MessageResult 'Method_TextDocumentCodeAction
combineResponses SMethod 'Method_TextDocumentCodeAction
_method Config
_config (ClientCapabilities Maybe WorkspaceClientCapabilities
_ Maybe TextDocumentClientCapabilities
textDocCaps Maybe NotebookDocumentClientCapabilities
_ Maybe WindowClientCapabilities
_ Maybe GeneralClientCapabilities
_ Maybe Value
_) (CodeActionParams Maybe ProgressToken
_ Maybe ProgressToken
_ TextDocumentIdentifier
_ Range
_ CodeActionContext
context) NonEmpty (MessageResult 'Method_TextDocumentCodeAction)
resps =
      [Command |? CodeAction] -> [Command |? CodeAction] |? Null
forall a b. a -> a |? b
InL ([Command |? CodeAction] -> [Command |? CodeAction] |? Null)
-> [Command |? CodeAction] -> [Command |? CodeAction] |? Null
forall a b. (a -> b) -> a -> b
$ ((Command |? CodeAction) -> Command |? CodeAction)
-> [Command |? CodeAction] -> [Command |? CodeAction]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Command |? CodeAction) -> Command |? CodeAction
compat ([Command |? CodeAction] -> [Command |? CodeAction])
-> [Command |? CodeAction] -> [Command |? CodeAction]
forall a b. (a -> b) -> a -> b
$ ([Command |? CodeAction] -> [Command |? CodeAction])
-> [[Command |? CodeAction]] -> [Command |? CodeAction]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Command |? CodeAction) -> Bool)
-> [Command |? CodeAction] -> [Command |? CodeAction]
forall a. (a -> Bool) -> [a] -> [a]
filter (Command |? CodeAction) -> Bool
wasRequested) ([[Command |? CodeAction]] -> [Command |? CodeAction])
-> [[Command |? CodeAction]] -> [Command |? CodeAction]
forall a b. (a -> b) -> a -> b
$ (([Command |? CodeAction] |? Null)
 -> Maybe [Command |? CodeAction])
-> [[Command |? CodeAction] |? Null] -> [[Command |? CodeAction]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Command |? CodeAction] |? Null) -> Maybe [Command |? CodeAction]
forall a. (a |? Null) -> Maybe a
nullToMaybe ([[Command |? CodeAction] |? Null] -> [[Command |? CodeAction]])
-> [[Command |? CodeAction] |? Null] -> [[Command |? CodeAction]]
forall a b. (a -> b) -> a -> b
$ NonEmpty ([Command |? CodeAction] |? Null)
-> [[Command |? CodeAction] |? Null]
forall a. NonEmpty a -> [a]
toList NonEmpty (MessageResult 'Method_TextDocumentCodeAction)
NonEmpty ([Command |? CodeAction] |? Null)
resps
    where
      compat :: (Command |? CodeAction) -> (Command |? CodeAction)
      compat :: (Command |? CodeAction) -> Command |? CodeAction
compat x :: Command |? CodeAction
x@(InL Command
_) = Command |? CodeAction
x
      compat x :: Command |? CodeAction
x@(InR CodeAction
action)
        | Just ClientCodeActionLiteralOptions
_ <- Maybe TextDocumentClientCapabilities
textDocCaps Maybe TextDocumentClientCapabilities
-> (TextDocumentClientCapabilities
    -> Maybe CodeActionClientCapabilities)
-> Maybe CodeActionClientCapabilities
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TextDocumentClientCapabilities
-> Maybe CodeActionClientCapabilities
_codeAction Maybe CodeActionClientCapabilities
-> (CodeActionClientCapabilities
    -> Maybe ClientCodeActionLiteralOptions)
-> Maybe ClientCodeActionLiteralOptions
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CodeActionClientCapabilities
-> Maybe ClientCodeActionLiteralOptions
_codeActionLiteralSupport
        = Command |? CodeAction
x
        | Bool
otherwise = Command -> Command |? CodeAction
forall a b. a -> a |? b
InL Command
cmd
        where
          cmd :: Command
cmd = PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
"hls" CommandId
"fallbackCodeAction" (CodeAction
action CodeAction -> Getting Text CodeAction Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text CodeAction Text
forall s a. HasTitle s a => Lens' s a
Lens' CodeAction Text
L.title) ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Value]
cmdParams)
          cmdParams :: [Value]
cmdParams = [FallbackCodeActionParams -> Value
forall a. ToJSON a => a -> Value
toJSON (Maybe WorkspaceEdit -> Maybe Command -> FallbackCodeActionParams
FallbackCodeActionParams (CodeAction
action CodeAction
-> Getting (Maybe WorkspaceEdit) CodeAction (Maybe WorkspaceEdit)
-> Maybe WorkspaceEdit
forall s a. s -> Getting a s a -> a
^. Getting (Maybe WorkspaceEdit) CodeAction (Maybe WorkspaceEdit)
forall s a. HasEdit s a => Lens' s a
Lens' CodeAction (Maybe WorkspaceEdit)
L.edit) (CodeAction
action CodeAction
-> Getting (Maybe Command) CodeAction (Maybe Command)
-> Maybe Command
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Command) CodeAction (Maybe Command)
forall s a. HasCommand s a => Lens' s a
Lens' CodeAction (Maybe Command)
L.command))]

      wasRequested :: (Command |? CodeAction) -> Bool
      wasRequested :: (Command |? CodeAction) -> Bool
wasRequested (InL Command
_) = Bool
True
      wasRequested (InR CodeAction
ca)
        | Maybe [CodeActionKind]
Nothing <- CodeActionContext -> Maybe [CodeActionKind]
_only CodeActionContext
context = Bool
True
        | Just [CodeActionKind]
allowed <- CodeActionContext -> Maybe [CodeActionKind]
_only CodeActionContext
context
        -- See https://github.com/microsoft/language-server-protocol/issues/970
        -- This is somewhat vague, but due to the hierarchical nature of action kinds, we
        -- should check whether the requested kind is a *prefix* of the action kind.
        -- That means, for example, we will return actions with kinds `quickfix.import` and
        -- `quickfix.somethingElse` if the requested kind is `quickfix`.
        , Just CodeActionKind
caKind <- CodeAction
ca CodeAction
-> Getting (Maybe CodeActionKind) CodeAction (Maybe CodeActionKind)
-> Maybe CodeActionKind
forall s a. s -> Getting a s a -> a
^. Getting (Maybe CodeActionKind) CodeAction (Maybe CodeActionKind)
forall s a. HasKind s a => Lens' s a
Lens' CodeAction (Maybe CodeActionKind)
L.kind = (CodeActionKind -> Bool) -> [CodeActionKind] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CodeActionKind -> CodeActionKind -> Bool
`codeActionKindSubsumes` CodeActionKind
caKind) [CodeActionKind]
allowed
        | Bool
otherwise = Bool
False

instance PluginRequestMethod Method_CodeActionResolve where
    -- A resolve request should only have one response.
    -- See Note [Resolve in PluginHandlers].
    combineResponses :: SMethod 'Method_CodeActionResolve
-> Config
-> ClientCapabilities
-> MessageParams 'Method_CodeActionResolve
-> NonEmpty (MessageResult 'Method_CodeActionResolve)
-> MessageResult 'Method_CodeActionResolve
combineResponses SMethod 'Method_CodeActionResolve
_ Config
_ ClientCapabilities
_ MessageParams 'Method_CodeActionResolve
_ (MessageResult 'Method_CodeActionResolve
x :| [MessageResult 'Method_CodeActionResolve]
_) = MessageResult 'Method_CodeActionResolve
x

instance PluginRequestMethod Method_TextDocumentDefinition where
    combineResponses :: SMethod 'Method_TextDocumentDefinition
-> Config
-> ClientCapabilities
-> MessageParams 'Method_TextDocumentDefinition
-> NonEmpty (MessageResult 'Method_TextDocumentDefinition)
-> MessageResult 'Method_TextDocumentDefinition
combineResponses SMethod 'Method_TextDocumentDefinition
_ Config
_ ClientCapabilities
caps MessageParams 'Method_TextDocumentDefinition
_ (MessageResult 'Method_TextDocumentDefinition
x :| [MessageResult 'Method_TextDocumentDefinition]
xs)
        | Just (Just Bool
True) <- ClientCapabilities
caps ClientCapabilities
-> Getting (First (Maybe Bool)) ClientCapabilities (Maybe Bool)
-> Maybe (Maybe Bool)
forall s a. s -> Getting (First a) s a -> Maybe a
^? ((Maybe TextDocumentClientCapabilities
 -> Const
      (First (Maybe Bool)) (Maybe TextDocumentClientCapabilities))
-> ClientCapabilities
-> Const (First (Maybe Bool)) ClientCapabilities
forall s a. HasTextDocument s a => Lens' s a
Lens' ClientCapabilities (Maybe TextDocumentClientCapabilities)
L.textDocument ((Maybe TextDocumentClientCapabilities
  -> Const
       (First (Maybe Bool)) (Maybe TextDocumentClientCapabilities))
 -> ClientCapabilities
 -> Const (First (Maybe Bool)) ClientCapabilities)
-> ((Maybe Bool -> Const (First (Maybe Bool)) (Maybe Bool))
    -> Maybe TextDocumentClientCapabilities
    -> Const
         (First (Maybe Bool)) (Maybe TextDocumentClientCapabilities))
-> Getting (First (Maybe Bool)) ClientCapabilities (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentClientCapabilities
 -> Const (First (Maybe Bool)) TextDocumentClientCapabilities)
-> Maybe TextDocumentClientCapabilities
-> Const
     (First (Maybe Bool)) (Maybe TextDocumentClientCapabilities)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((TextDocumentClientCapabilities
  -> Const (First (Maybe Bool)) TextDocumentClientCapabilities)
 -> Maybe TextDocumentClientCapabilities
 -> Const
      (First (Maybe Bool)) (Maybe TextDocumentClientCapabilities))
-> ((Maybe Bool -> Const (First (Maybe Bool)) (Maybe Bool))
    -> TextDocumentClientCapabilities
    -> Const (First (Maybe Bool)) TextDocumentClientCapabilities)
-> (Maybe Bool -> Const (First (Maybe Bool)) (Maybe Bool))
-> Maybe TextDocumentClientCapabilities
-> Const
     (First (Maybe Bool)) (Maybe TextDocumentClientCapabilities)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe DefinitionClientCapabilities
 -> Const (First (Maybe Bool)) (Maybe DefinitionClientCapabilities))
-> TextDocumentClientCapabilities
-> Const (First (Maybe Bool)) TextDocumentClientCapabilities
forall s a. HasDefinition s a => Lens' s a
Lens'
  TextDocumentClientCapabilities (Maybe DefinitionClientCapabilities)
L.definition ((Maybe DefinitionClientCapabilities
  -> Const (First (Maybe Bool)) (Maybe DefinitionClientCapabilities))
 -> TextDocumentClientCapabilities
 -> Const (First (Maybe Bool)) TextDocumentClientCapabilities)
-> ((Maybe Bool -> Const (First (Maybe Bool)) (Maybe Bool))
    -> Maybe DefinitionClientCapabilities
    -> Const (First (Maybe Bool)) (Maybe DefinitionClientCapabilities))
-> (Maybe Bool -> Const (First (Maybe Bool)) (Maybe Bool))
-> TextDocumentClientCapabilities
-> Const (First (Maybe Bool)) TextDocumentClientCapabilities
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DefinitionClientCapabilities
 -> Const (First (Maybe Bool)) DefinitionClientCapabilities)
-> Maybe DefinitionClientCapabilities
-> Const (First (Maybe Bool)) (Maybe DefinitionClientCapabilities)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((DefinitionClientCapabilities
  -> Const (First (Maybe Bool)) DefinitionClientCapabilities)
 -> Maybe DefinitionClientCapabilities
 -> Const (First (Maybe Bool)) (Maybe DefinitionClientCapabilities))
-> ((Maybe Bool -> Const (First (Maybe Bool)) (Maybe Bool))
    -> DefinitionClientCapabilities
    -> Const (First (Maybe Bool)) DefinitionClientCapabilities)
-> (Maybe Bool -> Const (First (Maybe Bool)) (Maybe Bool))
-> Maybe DefinitionClientCapabilities
-> Const (First (Maybe Bool)) (Maybe DefinitionClientCapabilities)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Const (First (Maybe Bool)) (Maybe Bool))
-> DefinitionClientCapabilities
-> Const (First (Maybe Bool)) DefinitionClientCapabilities
forall s a. HasLinkSupport s a => Lens' s a
Lens' DefinitionClientCapabilities (Maybe Bool)
L.linkSupport) = (Definitions -> Definitions -> Definitions)
-> Definitions -> [Definitions] -> Definitions
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Definitions -> Definitions -> Definitions
mergeDefinitions MessageResult 'Method_TextDocumentDefinition
Definitions
x [MessageResult 'Method_TextDocumentDefinition]
[Definitions]
xs
        | Bool
otherwise = Definitions -> Definitions
downgradeLinks (Definitions -> Definitions) -> Definitions -> Definitions
forall a b. (a -> b) -> a -> b
$ (Definitions -> Definitions -> Definitions)
-> Definitions -> [Definitions] -> Definitions
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Definitions -> Definitions -> Definitions
mergeDefinitions MessageResult 'Method_TextDocumentDefinition
Definitions
x [MessageResult 'Method_TextDocumentDefinition]
[Definitions]
xs

instance PluginRequestMethod Method_TextDocumentTypeDefinition where
    combineResponses :: SMethod 'Method_TextDocumentTypeDefinition
-> Config
-> ClientCapabilities
-> MessageParams 'Method_TextDocumentTypeDefinition
-> NonEmpty (MessageResult 'Method_TextDocumentTypeDefinition)
-> MessageResult 'Method_TextDocumentTypeDefinition
combineResponses SMethod 'Method_TextDocumentTypeDefinition
_ Config
_ ClientCapabilities
caps MessageParams 'Method_TextDocumentTypeDefinition
_ (MessageResult 'Method_TextDocumentTypeDefinition
x :| [MessageResult 'Method_TextDocumentTypeDefinition]
xs)
        | Just (Just Bool
True) <- ClientCapabilities
caps ClientCapabilities
-> Getting (First (Maybe Bool)) ClientCapabilities (Maybe Bool)
-> Maybe (Maybe Bool)
forall s a. s -> Getting (First a) s a -> Maybe a
^? ((Maybe TextDocumentClientCapabilities
 -> Const
      (First (Maybe Bool)) (Maybe TextDocumentClientCapabilities))
-> ClientCapabilities
-> Const (First (Maybe Bool)) ClientCapabilities
forall s a. HasTextDocument s a => Lens' s a
Lens' ClientCapabilities (Maybe TextDocumentClientCapabilities)
L.textDocument ((Maybe TextDocumentClientCapabilities
  -> Const
       (First (Maybe Bool)) (Maybe TextDocumentClientCapabilities))
 -> ClientCapabilities
 -> Const (First (Maybe Bool)) ClientCapabilities)
-> ((Maybe Bool -> Const (First (Maybe Bool)) (Maybe Bool))
    -> Maybe TextDocumentClientCapabilities
    -> Const
         (First (Maybe Bool)) (Maybe TextDocumentClientCapabilities))
-> Getting (First (Maybe Bool)) ClientCapabilities (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextDocumentClientCapabilities
 -> Const (First (Maybe Bool)) TextDocumentClientCapabilities)
-> Maybe TextDocumentClientCapabilities
-> Const
     (First (Maybe Bool)) (Maybe TextDocumentClientCapabilities)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((TextDocumentClientCapabilities
  -> Const (First (Maybe Bool)) TextDocumentClientCapabilities)
 -> Maybe TextDocumentClientCapabilities
 -> Const
      (First (Maybe Bool)) (Maybe TextDocumentClientCapabilities))
-> ((Maybe Bool -> Const (First (Maybe Bool)) (Maybe Bool))
    -> TextDocumentClientCapabilities
    -> Const (First (Maybe Bool)) TextDocumentClientCapabilities)
-> (Maybe Bool -> Const (First (Maybe Bool)) (Maybe Bool))
-> Maybe TextDocumentClientCapabilities
-> Const
     (First (Maybe Bool)) (Maybe TextDocumentClientCapabilities)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe TypeDefinitionClientCapabilities
 -> Const
      (First (Maybe Bool)) (Maybe TypeDefinitionClientCapabilities))
-> TextDocumentClientCapabilities
-> Const (First (Maybe Bool)) TextDocumentClientCapabilities
forall s a. HasTypeDefinition s a => Lens' s a
Lens'
  TextDocumentClientCapabilities
  (Maybe TypeDefinitionClientCapabilities)
L.typeDefinition ((Maybe TypeDefinitionClientCapabilities
  -> Const
       (First (Maybe Bool)) (Maybe TypeDefinitionClientCapabilities))
 -> TextDocumentClientCapabilities
 -> Const (First (Maybe Bool)) TextDocumentClientCapabilities)
-> ((Maybe Bool -> Const (First (Maybe Bool)) (Maybe Bool))
    -> Maybe TypeDefinitionClientCapabilities
    -> Const
         (First (Maybe Bool)) (Maybe TypeDefinitionClientCapabilities))
-> (Maybe Bool -> Const (First (Maybe Bool)) (Maybe Bool))
-> TextDocumentClientCapabilities
-> Const (First (Maybe Bool)) TextDocumentClientCapabilities
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeDefinitionClientCapabilities
 -> Const (First (Maybe Bool)) TypeDefinitionClientCapabilities)
-> Maybe TypeDefinitionClientCapabilities
-> Const
     (First (Maybe Bool)) (Maybe TypeDefinitionClientCapabilities)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((TypeDefinitionClientCapabilities
  -> Const (First (Maybe Bool)) TypeDefinitionClientCapabilities)
 -> Maybe TypeDefinitionClientCapabilities
 -> Const
      (First (Maybe Bool)) (Maybe TypeDefinitionClientCapabilities))
-> ((Maybe Bool -> Const (First (Maybe Bool)) (Maybe Bool))
    -> TypeDefinitionClientCapabilities
    -> Const (First (Maybe Bool)) TypeDefinitionClientCapabilities)
-> (Maybe Bool -> Const (First (Maybe Bool)) (Maybe Bool))
-> Maybe TypeDefinitionClientCapabilities
-> Const
     (First (Maybe Bool)) (Maybe TypeDefinitionClientCapabilities)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Const (First (Maybe Bool)) (Maybe Bool))
-> TypeDefinitionClientCapabilities
-> Const (First (Maybe Bool)) TypeDefinitionClientCapabilities
forall s a. HasLinkSupport s a => Lens' s a
Lens' TypeDefinitionClientCapabilities (Maybe Bool)
L.linkSupport) = (Definitions -> Definitions -> Definitions)
-> Definitions -> [Definitions] -> Definitions
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Definitions -> Definitions -> Definitions
mergeDefinitions MessageResult 'Method_TextDocumentTypeDefinition
Definitions
x [MessageResult 'Method_TextDocumentTypeDefinition]
[Definitions]
xs
        | Bool
otherwise = Definitions -> Definitions
downgradeLinks (Definitions -> Definitions) -> Definitions -> Definitions
forall a b. (a -> b) -> a -> b
$ (Definitions -> Definitions -> Definitions)
-> Definitions -> [Definitions] -> Definitions
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Definitions -> Definitions -> Definitions
mergeDefinitions MessageResult 'Method_TextDocumentTypeDefinition
Definitions
x [MessageResult 'Method_TextDocumentTypeDefinition]
[Definitions]
xs

instance PluginRequestMethod Method_TextDocumentDocumentHighlight where

instance PluginRequestMethod Method_TextDocumentReferences where

instance PluginRequestMethod Method_WorkspaceSymbol where
    -- TODO: combine WorkspaceSymbol. Currently all WorkspaceSymbols are dumped
    -- as it is new of lsp-types 2.0.0.0
    combineResponses :: SMethod 'Method_WorkspaceSymbol
-> Config
-> ClientCapabilities
-> MessageParams 'Method_WorkspaceSymbol
-> NonEmpty (MessageResult 'Method_WorkspaceSymbol)
-> MessageResult 'Method_WorkspaceSymbol
combineResponses SMethod 'Method_WorkspaceSymbol
_ Config
_ ClientCapabilities
_ MessageParams 'Method_WorkspaceSymbol
_ NonEmpty (MessageResult 'Method_WorkspaceSymbol)
xs = [SymbolInformation]
-> [SymbolInformation] |? ([WorkspaceSymbol] |? Null)
forall a b. a -> a |? b
InL ([SymbolInformation]
 -> [SymbolInformation] |? ([WorkspaceSymbol] |? Null))
-> [SymbolInformation]
-> [SymbolInformation] |? ([WorkspaceSymbol] |? Null)
forall a b. (a -> b) -> a -> b
$ [[SymbolInformation]] -> [SymbolInformation]
forall a. Monoid a => [a] -> a
mconcat ([[SymbolInformation]] -> [SymbolInformation])
-> [[SymbolInformation]] -> [SymbolInformation]
forall a b. (a -> b) -> a -> b
$ [[SymbolInformation] |? ([WorkspaceSymbol] |? Null)]
-> [[SymbolInformation]]
forall a b. [a |? b] -> [a]
takeLefts ([[SymbolInformation] |? ([WorkspaceSymbol] |? Null)]
 -> [[SymbolInformation]])
-> [[SymbolInformation] |? ([WorkspaceSymbol] |? Null)]
-> [[SymbolInformation]]
forall a b. (a -> b) -> a -> b
$ NonEmpty ([SymbolInformation] |? ([WorkspaceSymbol] |? Null))
-> [[SymbolInformation] |? ([WorkspaceSymbol] |? Null)]
forall a. NonEmpty a -> [a]
toList NonEmpty (MessageResult 'Method_WorkspaceSymbol)
NonEmpty ([SymbolInformation] |? ([WorkspaceSymbol] |? Null))
xs

instance PluginRequestMethod Method_TextDocumentCodeLens where

instance PluginRequestMethod Method_CodeLensResolve where
    -- A resolve request should only ever get one response.
    -- See note Note [Resolve in PluginHandlers]
    combineResponses :: SMethod 'Method_CodeLensResolve
-> Config
-> ClientCapabilities
-> MessageParams 'Method_CodeLensResolve
-> NonEmpty (MessageResult 'Method_CodeLensResolve)
-> MessageResult 'Method_CodeLensResolve
combineResponses SMethod 'Method_CodeLensResolve
_ Config
_ ClientCapabilities
_ MessageParams 'Method_CodeLensResolve
_ (MessageResult 'Method_CodeLensResolve
x :| [MessageResult 'Method_CodeLensResolve]
_) = MessageResult 'Method_CodeLensResolve
x

instance PluginRequestMethod Method_TextDocumentRename where

instance PluginRequestMethod Method_TextDocumentPrepareRename where
    -- TODO more intelligent combining?
    combineResponses :: SMethod 'Method_TextDocumentPrepareRename
-> Config
-> ClientCapabilities
-> MessageParams 'Method_TextDocumentPrepareRename
-> NonEmpty (MessageResult 'Method_TextDocumentPrepareRename)
-> MessageResult 'Method_TextDocumentPrepareRename
combineResponses SMethod 'Method_TextDocumentPrepareRename
_ Config
_ ClientCapabilities
_ MessageParams 'Method_TextDocumentPrepareRename
_ (MessageResult 'Method_TextDocumentPrepareRename
x :| [MessageResult 'Method_TextDocumentPrepareRename]
_) = MessageResult 'Method_TextDocumentPrepareRename
x

instance PluginRequestMethod Method_TextDocumentHover where
  combineResponses :: SMethod 'Method_TextDocumentHover
-> Config
-> ClientCapabilities
-> MessageParams 'Method_TextDocumentHover
-> NonEmpty (MessageResult 'Method_TextDocumentHover)
-> MessageResult 'Method_TextDocumentHover
combineResponses SMethod 'Method_TextDocumentHover
_ Config
_ ClientCapabilities
_ MessageParams 'Method_TextDocumentHover
_ (((Hover |? Null) -> Maybe Hover) -> [Hover |? Null] -> [Hover]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Hover |? Null) -> Maybe Hover
forall a. (a |? Null) -> Maybe a
nullToMaybe ([Hover |? Null] -> [Hover])
-> (NonEmpty (Hover |? Null) -> [Hover |? Null])
-> NonEmpty (Hover |? Null)
-> [Hover]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Hover |? Null) -> [Hover |? Null]
forall a. NonEmpty a -> [a]
toList -> [Hover]
hs :: [Hover]) =
    if [Hover] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Hover]
hs
        then Null -> Hover |? Null
forall a b. b -> a |? b
InR Null
Null
        else Hover -> Hover |? Null
forall a b. a -> a |? b
InL (Hover -> Hover |? Null) -> Hover -> Hover |? Null
forall a b. (a -> b) -> a -> b
$ (MarkupContent |? (MarkedString |? [MarkedString]))
-> Maybe Range -> Hover
Hover (MarkupContent -> MarkupContent |? (MarkedString |? [MarkedString])
forall a b. a -> a |? b
InL MarkupContent
mcontent) Maybe Range
r
    where
      r :: Maybe Range
r = [Range] -> Maybe Range
forall a. [a] -> Maybe a
listToMaybe ([Range] -> Maybe Range) -> [Range] -> Maybe Range
forall a b. (a -> b) -> a -> b
$ (Hover -> Maybe Range) -> [Hover] -> [Range]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Hover -> Getting (Maybe Range) Hover (Maybe Range) -> Maybe Range
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Range) Hover (Maybe Range)
forall s a. HasRange s a => Lens' s a
Lens' Hover (Maybe Range)
L.range) [Hover]
hs
      -- We are only taking MarkupContent here, because MarkedStrings have been
      -- deprecated for a while and don't occur in the hls codebase
      mcontent :: MarkupContent
      mcontent :: MarkupContent
mcontent = [MarkupContent] -> MarkupContent
forall a. Monoid a => [a] -> a
mconcat ([MarkupContent] -> MarkupContent)
-> [MarkupContent] -> MarkupContent
forall a b. (a -> b) -> a -> b
$ [MarkupContent |? (MarkedString |? [MarkedString])]
-> [MarkupContent]
forall a b. [a |? b] -> [a]
takeLefts ([MarkupContent |? (MarkedString |? [MarkedString])]
 -> [MarkupContent])
-> [MarkupContent |? (MarkedString |? [MarkedString])]
-> [MarkupContent]
forall a b. (a -> b) -> a -> b
$ (Hover -> MarkupContent |? (MarkedString |? [MarkedString]))
-> [Hover] -> [MarkupContent |? (MarkedString |? [MarkedString])]
forall a b. (a -> b) -> [a] -> [b]
map (Hover
-> Getting
     (MarkupContent |? (MarkedString |? [MarkedString]))
     Hover
     (MarkupContent |? (MarkedString |? [MarkedString]))
-> MarkupContent |? (MarkedString |? [MarkedString])
forall s a. s -> Getting a s a -> a
^. Getting
  (MarkupContent |? (MarkedString |? [MarkedString]))
  Hover
  (MarkupContent |? (MarkedString |? [MarkedString]))
forall s a. HasContents s a => Lens' s a
Lens' Hover (MarkupContent |? (MarkedString |? [MarkedString]))
L.contents) [Hover]
hs

instance PluginRequestMethod Method_TextDocumentDocumentSymbol where
  combineResponses :: SMethod 'Method_TextDocumentDocumentSymbol
-> Config
-> ClientCapabilities
-> MessageParams 'Method_TextDocumentDocumentSymbol
-> NonEmpty (MessageResult 'Method_TextDocumentDocumentSymbol)
-> MessageResult 'Method_TextDocumentDocumentSymbol
combineResponses SMethod 'Method_TextDocumentDocumentSymbol
_ Config
_ (ClientCapabilities Maybe WorkspaceClientCapabilities
_ Maybe TextDocumentClientCapabilities
tdc Maybe NotebookDocumentClientCapabilities
_ Maybe WindowClientCapabilities
_ Maybe GeneralClientCapabilities
_ Maybe Value
_) MessageParams 'Method_TextDocumentDocumentSymbol
params NonEmpty (MessageResult 'Method_TextDocumentDocumentSymbol)
xs = MessageResult 'Method_TextDocumentDocumentSymbol
[SymbolInformation] |? ([DocumentSymbol] |? Null)
res
    where
      uri' :: Uri
uri' = MessageParams 'Method_TextDocumentDocumentSymbol
DocumentSymbolParams
params DocumentSymbolParams -> Getting Uri DocumentSymbolParams Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> DocumentSymbolParams -> Const Uri DocumentSymbolParams
forall s a. HasTextDocument s a => Lens' s a
Lens' DocumentSymbolParams TextDocumentIdentifier
L.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> DocumentSymbolParams -> Const Uri DocumentSymbolParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> Getting Uri DocumentSymbolParams Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
L.uri
      supportsHierarchy :: Bool
supportsHierarchy = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== (Maybe TextDocumentClientCapabilities
tdc Maybe TextDocumentClientCapabilities
-> (TextDocumentClientCapabilities
    -> Maybe DocumentSymbolClientCapabilities)
-> Maybe DocumentSymbolClientCapabilities
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TextDocumentClientCapabilities
-> Maybe DocumentSymbolClientCapabilities
_documentSymbol Maybe DocumentSymbolClientCapabilities
-> (DocumentSymbolClientCapabilities -> Maybe Bool) -> Maybe Bool
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DocumentSymbolClientCapabilities -> Maybe Bool
_hierarchicalDocumentSymbolSupport)
      dsOrSi :: [Either [SymbolInformation] [DocumentSymbol]]
      dsOrSi :: [Either [SymbolInformation] [DocumentSymbol]]
dsOrSi =  ([SymbolInformation] |? [DocumentSymbol])
-> Either [SymbolInformation] [DocumentSymbol]
forall a b. (a |? b) -> Either a b
toEither (([SymbolInformation] |? [DocumentSymbol])
 -> Either [SymbolInformation] [DocumentSymbol])
-> [[SymbolInformation] |? [DocumentSymbol]]
-> [Either [SymbolInformation] [DocumentSymbol]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([SymbolInformation] |? ([DocumentSymbol] |? Null))
 -> Maybe ([SymbolInformation] |? [DocumentSymbol]))
-> [[SymbolInformation] |? ([DocumentSymbol] |? Null)]
-> [[SymbolInformation] |? [DocumentSymbol]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([SymbolInformation] |? ([DocumentSymbol] |? Null))
-> Maybe ([SymbolInformation] |? [DocumentSymbol])
forall a b. (a |? (b |? Null)) -> Maybe (a |? b)
nullToMaybe' (NonEmpty ([SymbolInformation] |? ([DocumentSymbol] |? Null))
-> [[SymbolInformation] |? ([DocumentSymbol] |? Null)]
forall a. NonEmpty a -> [a]
toList NonEmpty (MessageResult 'Method_TextDocumentDocumentSymbol)
NonEmpty ([SymbolInformation] |? ([DocumentSymbol] |? Null))
xs)
      res :: [SymbolInformation] |? ([DocumentSymbol] |? Null)
      res :: [SymbolInformation] |? ([DocumentSymbol] |? Null)
res
        | Bool
supportsHierarchy = ([DocumentSymbol] |? Null)
-> [SymbolInformation] |? ([DocumentSymbol] |? Null)
forall a b. b -> a |? b
InR (([DocumentSymbol] |? Null)
 -> [SymbolInformation] |? ([DocumentSymbol] |? Null))
-> ([DocumentSymbol] |? Null)
-> [SymbolInformation] |? ([DocumentSymbol] |? Null)
forall a b. (a -> b) -> a -> b
$ [DocumentSymbol] -> [DocumentSymbol] |? Null
forall a b. a -> a |? b
InL ([DocumentSymbol] -> [DocumentSymbol] |? Null)
-> [DocumentSymbol] -> [DocumentSymbol] |? Null
forall a b. (a -> b) -> a -> b
$ (Either [SymbolInformation] [DocumentSymbol] -> [DocumentSymbol])
-> [Either [SymbolInformation] [DocumentSymbol]]
-> [DocumentSymbol]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([SymbolInformation] -> [DocumentSymbol])
-> ([DocumentSymbol] -> [DocumentSymbol])
-> Either [SymbolInformation] [DocumentSymbol]
-> [DocumentSymbol]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((SymbolInformation -> DocumentSymbol)
-> [SymbolInformation] -> [DocumentSymbol]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SymbolInformation -> DocumentSymbol
siToDs) [DocumentSymbol] -> [DocumentSymbol]
forall a. a -> a
id) [Either [SymbolInformation] [DocumentSymbol]]
dsOrSi
        | Bool
otherwise = [SymbolInformation]
-> [SymbolInformation] |? ([DocumentSymbol] |? Null)
forall a b. a -> a |? b
InL ([SymbolInformation]
 -> [SymbolInformation] |? ([DocumentSymbol] |? Null))
-> [SymbolInformation]
-> [SymbolInformation] |? ([DocumentSymbol] |? Null)
forall a b. (a -> b) -> a -> b
$ (Either [SymbolInformation] [DocumentSymbol]
 -> [SymbolInformation])
-> [Either [SymbolInformation] [DocumentSymbol]]
-> [SymbolInformation]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([SymbolInformation] -> [SymbolInformation])
-> ([DocumentSymbol] -> [SymbolInformation])
-> Either [SymbolInformation] [DocumentSymbol]
-> [SymbolInformation]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [SymbolInformation] -> [SymbolInformation]
forall a. a -> a
id ( (DocumentSymbol -> [SymbolInformation])
-> [DocumentSymbol] -> [SymbolInformation]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DocumentSymbol -> [SymbolInformation]
dsToSi)) [Either [SymbolInformation] [DocumentSymbol]]
dsOrSi
      -- Is this actually a good conversion? It's what there was before, but some
      -- things such as tags are getting lost
      siToDs :: SymbolInformation -> DocumentSymbol
      siToDs :: SymbolInformation -> DocumentSymbol
siToDs (SymbolInformation Text
name SymbolKind
kind Maybe [SymbolTag]
_tags Maybe Text
cont Maybe Bool
dep (Location Uri
_uri Range
range) )
        = Text
-> Maybe Text
-> SymbolKind
-> Maybe [SymbolTag]
-> Maybe Bool
-> Range
-> Range
-> Maybe [DocumentSymbol]
-> DocumentSymbol
DocumentSymbol Text
name Maybe Text
cont SymbolKind
kind Maybe [SymbolTag]
forall a. Maybe a
Nothing Maybe Bool
dep Range
range Range
range Maybe [DocumentSymbol]
forall a. Maybe a
Nothing
      dsToSi :: DocumentSymbol -> [SymbolInformation]
dsToSi = Maybe Text -> DocumentSymbol -> [SymbolInformation]
go Maybe Text
forall a. Maybe a
Nothing
      go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation]
      go :: Maybe Text -> DocumentSymbol -> [SymbolInformation]
go Maybe Text
parent DocumentSymbol
ds =
        let children' :: [SymbolInformation]
            children' :: [SymbolInformation]
children' = (DocumentSymbol -> [SymbolInformation])
-> [DocumentSymbol] -> [SymbolInformation]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe Text -> DocumentSymbol -> [SymbolInformation]
go (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name')) ([DocumentSymbol] -> Maybe [DocumentSymbol] -> [DocumentSymbol]
forall a. a -> Maybe a -> a
fromMaybe [DocumentSymbol]
forall a. Monoid a => a
mempty (DocumentSymbol
ds DocumentSymbol
-> Getting
     (Maybe [DocumentSymbol]) DocumentSymbol (Maybe [DocumentSymbol])
-> Maybe [DocumentSymbol]
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe [DocumentSymbol]) DocumentSymbol (Maybe [DocumentSymbol])
forall s a. HasChildren s a => Lens' s a
Lens' DocumentSymbol (Maybe [DocumentSymbol])
L.children))
            loc :: Location
loc = Uri -> Range -> Location
Location Uri
uri' (DocumentSymbol
ds DocumentSymbol -> Getting Range DocumentSymbol Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range DocumentSymbol Range
forall s a. HasRange s a => Lens' s a
Lens' DocumentSymbol Range
L.range)
            name' :: Text
name' = DocumentSymbol
ds DocumentSymbol -> Getting Text DocumentSymbol Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text DocumentSymbol Text
forall s a. HasName s a => Lens' s a
Lens' DocumentSymbol Text
L.name
            si :: SymbolInformation
si = Text
-> SymbolKind
-> Maybe [SymbolTag]
-> Maybe Text
-> Maybe Bool
-> Location
-> SymbolInformation
SymbolInformation Text
name' (DocumentSymbol
ds DocumentSymbol
-> Getting SymbolKind DocumentSymbol SymbolKind -> SymbolKind
forall s a. s -> Getting a s a -> a
^. Getting SymbolKind DocumentSymbol SymbolKind
forall s a. HasKind s a => Lens' s a
Lens' DocumentSymbol SymbolKind
L.kind) Maybe [SymbolTag]
forall a. Maybe a
Nothing Maybe Text
parent (DocumentSymbol
ds DocumentSymbol
-> Getting (Maybe Bool) DocumentSymbol (Maybe Bool) -> Maybe Bool
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Bool) DocumentSymbol (Maybe Bool)
forall s a. HasDeprecated s a => Lens' s a
Lens' DocumentSymbol (Maybe Bool)
L.deprecated) Location
loc
        in [SymbolInformation
si] [SymbolInformation] -> [SymbolInformation] -> [SymbolInformation]
forall a. Semigroup a => a -> a -> a
<> [SymbolInformation]
children'

instance PluginRequestMethod Method_CompletionItemResolve where
  -- A resolve request should only have one response.
  -- See Note [Resolve in PluginHandlers]
  combineResponses :: SMethod 'Method_CompletionItemResolve
-> Config
-> ClientCapabilities
-> MessageParams 'Method_CompletionItemResolve
-> NonEmpty (MessageResult 'Method_CompletionItemResolve)
-> MessageResult 'Method_CompletionItemResolve
combineResponses SMethod 'Method_CompletionItemResolve
_ Config
_ ClientCapabilities
_ MessageParams 'Method_CompletionItemResolve
_ (MessageResult 'Method_CompletionItemResolve
x :| [MessageResult 'Method_CompletionItemResolve]
_) = MessageResult 'Method_CompletionItemResolve
x

instance PluginRequestMethod Method_TextDocumentCompletion where
  combineResponses :: SMethod 'Method_TextDocumentCompletion
-> Config
-> ClientCapabilities
-> MessageParams 'Method_TextDocumentCompletion
-> NonEmpty (MessageResult 'Method_TextDocumentCompletion)
-> MessageResult 'Method_TextDocumentCompletion
combineResponses SMethod 'Method_TextDocumentCompletion
_ Config
conf ClientCapabilities
_ MessageParams 'Method_TextDocumentCompletion
_ (NonEmpty (MessageResult 'Method_TextDocumentCompletion)
-> [[CompletionItem] |? (CompletionList |? Null)]
NonEmpty ([CompletionItem] |? (CompletionList |? Null))
-> [[CompletionItem] |? (CompletionList |? Null)]
forall a. NonEmpty a -> [a]
toList -> [[CompletionItem] |? (CompletionList |? Null)]
xs) = (Int, MessageResult 'Method_TextDocumentCompletion)
-> MessageResult 'Method_TextDocumentCompletion
forall a b. (a, b) -> b
snd ((Int, MessageResult 'Method_TextDocumentCompletion)
 -> MessageResult 'Method_TextDocumentCompletion)
-> (Int, MessageResult 'Method_TextDocumentCompletion)
-> MessageResult 'Method_TextDocumentCompletion
forall a b. (a -> b) -> a -> b
$ Int
-> ([CompletionItem] |? (CompletionList |? Null))
-> (Int, [CompletionItem] |? (CompletionList |? Null))
consumeCompletionResponse Int
limit (([CompletionItem] |? (CompletionList |? Null))
 -> (Int, [CompletionItem] |? (CompletionList |? Null)))
-> ([CompletionItem] |? (CompletionList |? Null))
-> (Int, [CompletionItem] |? (CompletionList |? Null))
forall a b. (a -> b) -> a -> b
$ [[CompletionItem] |? (CompletionList |? Null)]
-> [CompletionItem] |? (CompletionList |? Null)
combine [[CompletionItem] |? (CompletionList |? Null)]
xs
      where
        limit :: Int
limit = Config -> Int
maxCompletions Config
conf
        combine :: [[CompletionItem] |? (CompletionList |? Null)] -> ([CompletionItem] |? (CompletionList |? Null))
        combine :: [[CompletionItem] |? (CompletionList |? Null)]
-> [CompletionItem] |? (CompletionList |? Null)
combine [[CompletionItem] |? (CompletionList |? Null)]
cs = Bool
-> DList CompletionItem
-> [[CompletionItem] |? (CompletionList |? Null)]
-> [CompletionItem] |? (CompletionList |? Null)
go Bool
True DList CompletionItem
forall a. Monoid a => a
mempty [[CompletionItem] |? (CompletionList |? Null)]
cs

        go :: Bool -> DList.DList CompletionItem -> [[CompletionItem] |? (CompletionList |? Null)] -> ([CompletionItem] |? (CompletionList |? Null))
        go :: Bool
-> DList CompletionItem
-> [[CompletionItem] |? (CompletionList |? Null)]
-> [CompletionItem] |? (CompletionList |? Null)
go !Bool
comp DList CompletionItem
acc [] =
           (CompletionList |? Null)
-> [CompletionItem] |? (CompletionList |? Null)
forall a b. b -> a |? b
InR (CompletionList -> CompletionList |? Null
forall a b. a -> a |? b
InL (Bool
-> Maybe CompletionItemDefaults
-> [CompletionItem]
-> CompletionList
CompletionList Bool
comp Maybe CompletionItemDefaults
forall a. Maybe a
Nothing ( DList CompletionItem -> [CompletionItem]
forall a. DList a -> [a]
DList.toList DList CompletionItem
acc)))
        go Bool
comp DList CompletionItem
acc ((InL [CompletionItem]
ls) : [[CompletionItem] |? (CompletionList |? Null)]
rest) =
          Bool
-> DList CompletionItem
-> [[CompletionItem] |? (CompletionList |? Null)]
-> [CompletionItem] |? (CompletionList |? Null)
go Bool
comp (DList CompletionItem
acc DList CompletionItem
-> DList CompletionItem -> DList CompletionItem
forall a. Semigroup a => a -> a -> a
<> [CompletionItem] -> DList CompletionItem
forall a. [a] -> DList a
DList.fromList [CompletionItem]
ls) [[CompletionItem] |? (CompletionList |? Null)]
rest
        go Bool
comp DList CompletionItem
acc ( (InR (InL (CompletionList Bool
comp' Maybe CompletionItemDefaults
_ [CompletionItem]
ls))) : [[CompletionItem] |? (CompletionList |? Null)]
rest) =
          Bool
-> DList CompletionItem
-> [[CompletionItem] |? (CompletionList |? Null)]
-> [CompletionItem] |? (CompletionList |? Null)
go (Bool
comp Bool -> Bool -> Bool
&& Bool
comp') (DList CompletionItem
acc DList CompletionItem
-> DList CompletionItem -> DList CompletionItem
forall a. Semigroup a => a -> a -> a
<> [CompletionItem] -> DList CompletionItem
forall a. [a] -> DList a
DList.fromList [CompletionItem]
ls) [[CompletionItem] |? (CompletionList |? Null)]
rest
        go Bool
comp DList CompletionItem
acc ( (InR (InR Null
Null)) : [[CompletionItem] |? (CompletionList |? Null)]
rest) =
          Bool
-> DList CompletionItem
-> [[CompletionItem] |? (CompletionList |? Null)]
-> [CompletionItem] |? (CompletionList |? Null)
go Bool
comp DList CompletionItem
acc [[CompletionItem] |? (CompletionList |? Null)]
rest
        -- boolean disambiguators
        isCompleteResponse, isIncompleteResponse :: Bool
        isIncompleteResponse :: Bool
isIncompleteResponse = Bool
True
        isCompleteResponse :: Bool
isCompleteResponse = Bool
False
        consumeCompletionResponse :: Int -> ([CompletionItem] |? (CompletionList |? Null)) -> (Int, [CompletionItem] |? (CompletionList |? Null))
        consumeCompletionResponse :: Int
-> ([CompletionItem] |? (CompletionList |? Null))
-> (Int, [CompletionItem] |? (CompletionList |? Null))
consumeCompletionResponse Int
limit it :: [CompletionItem] |? (CompletionList |? Null)
it@(InR (InL (CompletionList Bool
_ Maybe CompletionItemDefaults
_ [CompletionItem]
xx))) =
          case Int -> [CompletionItem] -> ([CompletionItem], [CompletionItem])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
limit [CompletionItem]
xx of
            -- consumed all the items, return the result as is
            ([CompletionItem]
_, []) -> (Int
limit Int -> Int -> Int
forall a. Num a => a -> a -> a
- [CompletionItem] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CompletionItem]
xx, [CompletionItem] |? (CompletionList |? Null)
it)
            -- need to crop the response, set the 'isIncomplete' flag
            ([CompletionItem]
xx', [CompletionItem]
_) -> (Int
0, (CompletionList |? Null)
-> [CompletionItem] |? (CompletionList |? Null)
forall a b. b -> a |? b
InR (CompletionList -> CompletionList |? Null
forall a b. a -> a |? b
InL (Bool
-> Maybe CompletionItemDefaults
-> [CompletionItem]
-> CompletionList
CompletionList Bool
isIncompleteResponse Maybe CompletionItemDefaults
forall a. Maybe a
Nothing [CompletionItem]
xx')))
        consumeCompletionResponse Int
n (InL [CompletionItem]
xx) =
          Int
-> ([CompletionItem] |? (CompletionList |? Null))
-> (Int, [CompletionItem] |? (CompletionList |? Null))
consumeCompletionResponse Int
n ((CompletionList |? Null)
-> [CompletionItem] |? (CompletionList |? Null)
forall a b. b -> a |? b
InR (CompletionList -> CompletionList |? Null
forall a b. a -> a |? b
InL (Bool
-> Maybe CompletionItemDefaults
-> [CompletionItem]
-> CompletionList
CompletionList Bool
isCompleteResponse Maybe CompletionItemDefaults
forall a. Maybe a
Nothing [CompletionItem]
xx)))
        consumeCompletionResponse Int
n (InR (InR Null
Null)) = (Int
n, (CompletionList |? Null)
-> [CompletionItem] |? (CompletionList |? Null)
forall a b. b -> a |? b
InR (Null -> CompletionList |? Null
forall a b. b -> a |? b
InR Null
Null))
instance PluginRequestMethod Method_TextDocumentFormatting where
  combineResponses :: SMethod 'Method_TextDocumentFormatting
-> Config
-> ClientCapabilities
-> MessageParams 'Method_TextDocumentFormatting
-> NonEmpty (MessageResult 'Method_TextDocumentFormatting)
-> MessageResult 'Method_TextDocumentFormatting
combineResponses SMethod 'Method_TextDocumentFormatting
_ Config
_ ClientCapabilities
_ MessageParams 'Method_TextDocumentFormatting
_ (MessageResult 'Method_TextDocumentFormatting
x :| [MessageResult 'Method_TextDocumentFormatting]
_) = MessageResult 'Method_TextDocumentFormatting
x

instance PluginRequestMethod Method_TextDocumentRangeFormatting where
  combineResponses :: SMethod 'Method_TextDocumentRangeFormatting
-> Config
-> ClientCapabilities
-> MessageParams 'Method_TextDocumentRangeFormatting
-> NonEmpty (MessageResult 'Method_TextDocumentRangeFormatting)
-> MessageResult 'Method_TextDocumentRangeFormatting
combineResponses SMethod 'Method_TextDocumentRangeFormatting
_ Config
_ ClientCapabilities
_ MessageParams 'Method_TextDocumentRangeFormatting
_ (MessageResult 'Method_TextDocumentRangeFormatting
x :| [MessageResult 'Method_TextDocumentRangeFormatting]
_) = MessageResult 'Method_TextDocumentRangeFormatting
x

instance PluginRequestMethod Method_TextDocumentPrepareCallHierarchy where

instance PluginRequestMethod Method_TextDocumentSelectionRange where
  combineResponses :: SMethod 'Method_TextDocumentSelectionRange
-> Config
-> ClientCapabilities
-> MessageParams 'Method_TextDocumentSelectionRange
-> NonEmpty (MessageResult 'Method_TextDocumentSelectionRange)
-> MessageResult 'Method_TextDocumentSelectionRange
combineResponses SMethod 'Method_TextDocumentSelectionRange
_ Config
_ ClientCapabilities
_ MessageParams 'Method_TextDocumentSelectionRange
_ (MessageResult 'Method_TextDocumentSelectionRange
x :| [MessageResult 'Method_TextDocumentSelectionRange]
_) = MessageResult 'Method_TextDocumentSelectionRange
x

instance PluginRequestMethod Method_TextDocumentFoldingRange where
  combineResponses :: SMethod 'Method_TextDocumentFoldingRange
-> Config
-> ClientCapabilities
-> MessageParams 'Method_TextDocumentFoldingRange
-> NonEmpty (MessageResult 'Method_TextDocumentFoldingRange)
-> MessageResult 'Method_TextDocumentFoldingRange
combineResponses SMethod 'Method_TextDocumentFoldingRange
_ Config
_ ClientCapabilities
_ MessageParams 'Method_TextDocumentFoldingRange
_ NonEmpty (MessageResult 'Method_TextDocumentFoldingRange)
x = NonEmpty ([FoldingRange] |? Null) -> [FoldingRange] |? Null
forall a. Semigroup a => NonEmpty a -> a
sconcat NonEmpty (MessageResult 'Method_TextDocumentFoldingRange)
NonEmpty ([FoldingRange] |? Null)
x

instance PluginRequestMethod Method_CallHierarchyIncomingCalls where

instance PluginRequestMethod Method_CallHierarchyOutgoingCalls where

instance PluginRequestMethod (Method_CustomMethod m) where
  combineResponses :: SMethod ('Method_CustomMethod m)
-> Config
-> ClientCapabilities
-> MessageParams ('Method_CustomMethod m)
-> NonEmpty (MessageResult ('Method_CustomMethod m))
-> MessageResult ('Method_CustomMethod m)
combineResponses SMethod ('Method_CustomMethod m)
_ Config
_ ClientCapabilities
_ MessageParams ('Method_CustomMethod m)
_ (MessageResult ('Method_CustomMethod m)
x :| [MessageResult ('Method_CustomMethod m)]
_) = MessageResult ('Method_CustomMethod m)
x

instance PluginRequestMethod Method_TextDocumentSemanticTokensFull where
  combineResponses :: SMethod 'Method_TextDocumentSemanticTokensFull
-> Config
-> ClientCapabilities
-> MessageParams 'Method_TextDocumentSemanticTokensFull
-> NonEmpty (MessageResult 'Method_TextDocumentSemanticTokensFull)
-> MessageResult 'Method_TextDocumentSemanticTokensFull
combineResponses SMethod 'Method_TextDocumentSemanticTokensFull
_ Config
_ ClientCapabilities
_ MessageParams 'Method_TextDocumentSemanticTokensFull
_ (MessageResult 'Method_TextDocumentSemanticTokensFull
x :| [MessageResult 'Method_TextDocumentSemanticTokensFull]
_) = MessageResult 'Method_TextDocumentSemanticTokensFull
x

instance PluginRequestMethod Method_TextDocumentSemanticTokensFullDelta where
  combineResponses :: SMethod 'Method_TextDocumentSemanticTokensFullDelta
-> Config
-> ClientCapabilities
-> MessageParams 'Method_TextDocumentSemanticTokensFullDelta
-> NonEmpty
     (MessageResult 'Method_TextDocumentSemanticTokensFullDelta)
-> MessageResult 'Method_TextDocumentSemanticTokensFullDelta
combineResponses SMethod 'Method_TextDocumentSemanticTokensFullDelta
_ Config
_ ClientCapabilities
_ MessageParams 'Method_TextDocumentSemanticTokensFullDelta
_ (MessageResult 'Method_TextDocumentSemanticTokensFullDelta
x :| [MessageResult 'Method_TextDocumentSemanticTokensFullDelta]
_) = MessageResult 'Method_TextDocumentSemanticTokensFullDelta
x

takeLefts :: [a |? b] -> [a]
takeLefts :: forall a b. [a |? b] -> [a]
takeLefts = ((a |? b) -> Maybe a) -> [a |? b] -> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\a |? b
x -> [a
res | (InL a
res) <- (a |? b) -> Maybe (a |? b)
forall a. a -> Maybe a
Just a |? b
x])

nullToMaybe' :: (a |? (b |? Null)) -> Maybe (a |? b)
nullToMaybe' :: forall a b. (a |? (b |? Null)) -> Maybe (a |? b)
nullToMaybe' (InL a
x)       = (a |? b) -> Maybe (a |? b)
forall a. a -> Maybe a
Just ((a |? b) -> Maybe (a |? b)) -> (a |? b) -> Maybe (a |? b)
forall a b. (a -> b) -> a -> b
$ a -> a |? b
forall a b. a -> a |? b
InL a
x
nullToMaybe' (InR (InL b
x)) = (a |? b) -> Maybe (a |? b)
forall a. a -> Maybe a
Just ((a |? b) -> Maybe (a |? b)) -> (a |? b) -> Maybe (a |? b)
forall a b. (a -> b) -> a -> b
$ b -> a |? b
forall a b. b -> a |? b
InR b
x
nullToMaybe' (InR (InR Null
_)) = Maybe (a |? b)
forall a. Maybe a
Nothing

type Definitions = (Definition |? ([DefinitionLink] |? Null))

-- | Merges two definition responses (TextDocumentDefinition | TextDocumentTypeDefinition)
-- into one preserving all locations and their order (including order of the responses).
-- Upgrades Location(s) into LocationLink(s) when one of the responses is LocationLink(s). With following fields:
--  * LocationLink.originSelectionRange = Nothing
--  * LocationLink.targetUri = Location.Uri
--  * LocationLink.targetRange = Location.Range
--  * LocationLink.targetSelectionRange = Location.Range
-- Ignores Null responses.
mergeDefinitions :: Definitions -> Definitions -> Definitions
mergeDefinitions :: Definitions -> Definitions -> Definitions
mergeDefinitions Definitions
definitions1 Definitions
definitions2 = case (Definitions
definitions1, Definitions
definitions2) of
    (InR (InR Null
Null), Definitions
def2)               -> Definitions
def2
    (Definitions
def1, InR (InR Null
Null))               -> Definitions
def1
    (InL Definition
def1, InL Definition
def2)                 -> Definition -> Definitions
forall a b. a -> a |? b
InL (Definition -> Definitions) -> Definition -> Definitions
forall a b. (a -> b) -> a -> b
$ Definition -> Definition -> Definition
mergeDefs Definition
def1 Definition
def2
    (InL Definition
def1, InR (InL [DefinitionLink]
links))          -> ([DefinitionLink] |? Null) -> Definitions
forall a b. b -> a |? b
InR (([DefinitionLink] |? Null) -> Definitions)
-> ([DefinitionLink] |? Null) -> Definitions
forall a b. (a -> b) -> a -> b
$ [DefinitionLink] -> [DefinitionLink] |? Null
forall a b. a -> a |? b
InL (Definition -> [DefinitionLink]
defToLinks Definition
def1 [DefinitionLink] -> [DefinitionLink] -> [DefinitionLink]
forall a. [a] -> [a] -> [a]
++ [DefinitionLink]
links)
    (InR (InL [DefinitionLink]
links), InL Definition
def2)          -> ([DefinitionLink] |? Null) -> Definitions
forall a b. b -> a |? b
InR (([DefinitionLink] |? Null) -> Definitions)
-> ([DefinitionLink] |? Null) -> Definitions
forall a b. (a -> b) -> a -> b
$ [DefinitionLink] -> [DefinitionLink] |? Null
forall a b. a -> a |? b
InL ([DefinitionLink]
links [DefinitionLink] -> [DefinitionLink] -> [DefinitionLink]
forall a. [a] -> [a] -> [a]
++ Definition -> [DefinitionLink]
defToLinks Definition
def2)
    (InR (InL [DefinitionLink]
links1), InR (InL [DefinitionLink]
links2)) -> ([DefinitionLink] |? Null) -> Definitions
forall a b. b -> a |? b
InR (([DefinitionLink] |? Null) -> Definitions)
-> ([DefinitionLink] |? Null) -> Definitions
forall a b. (a -> b) -> a -> b
$ [DefinitionLink] -> [DefinitionLink] |? Null
forall a b. a -> a |? b
InL ([DefinitionLink]
links1 [DefinitionLink] -> [DefinitionLink] -> [DefinitionLink]
forall a. [a] -> [a] -> [a]
++ [DefinitionLink]
links2)
    where
        defToLinks :: Definition -> [DefinitionLink]
        defToLinks :: Definition -> [DefinitionLink]
defToLinks (Definition (InL Location
location)) = [Location -> DefinitionLink
locationToDefinitionLink Location
location]
        defToLinks (Definition (InR [Location]
locations)) = (Location -> DefinitionLink) -> [Location] -> [DefinitionLink]
forall a b. (a -> b) -> [a] -> [b]
map Location -> DefinitionLink
locationToDefinitionLink [Location]
locations

        locationToDefinitionLink :: Location -> DefinitionLink
        locationToDefinitionLink :: Location -> DefinitionLink
locationToDefinitionLink Location{Uri
_uri :: Uri
$sel:_uri:Location :: Location -> Uri
_uri, Range
_range :: Range
$sel:_range:Location :: Location -> Range
_range} = LocationLink -> DefinitionLink
DefinitionLink LocationLink{$sel:_originSelectionRange:LocationLink :: Maybe Range
_originSelectionRange = Maybe Range
forall a. Maybe a
Nothing, $sel:_targetUri:LocationLink :: Uri
_targetUri = Uri
_uri, $sel:_targetRange:LocationLink :: Range
_targetRange = Range
_range, $sel:_targetSelectionRange:LocationLink :: Range
_targetSelectionRange = Range
_range}

        mergeDefs :: Definition -> Definition -> Definition
        mergeDefs :: Definition -> Definition -> Definition
mergeDefs (Definition (InL Location
loc1)) (Definition (InL Location
loc2)) = (Location |? [Location]) -> Definition
Definition ((Location |? [Location]) -> Definition)
-> (Location |? [Location]) -> Definition
forall a b. (a -> b) -> a -> b
$ [Location] -> Location |? [Location]
forall a b. b -> a |? b
InR [Location
loc1, Location
loc2]
        mergeDefs (Definition (InR [Location]
locs1)) (Definition (InL Location
loc2)) = (Location |? [Location]) -> Definition
Definition ((Location |? [Location]) -> Definition)
-> (Location |? [Location]) -> Definition
forall a b. (a -> b) -> a -> b
$ [Location] -> Location |? [Location]
forall a b. b -> a |? b
InR ([Location]
locs1 [Location] -> [Location] -> [Location]
forall a. [a] -> [a] -> [a]
++ [Location
loc2])
        mergeDefs (Definition (InL Location
loc1)) (Definition (InR [Location]
locs2)) = (Location |? [Location]) -> Definition
Definition ((Location |? [Location]) -> Definition)
-> (Location |? [Location]) -> Definition
forall a b. (a -> b) -> a -> b
$ [Location] -> Location |? [Location]
forall a b. b -> a |? b
InR (Location
loc1 Location -> [Location] -> [Location]
forall a. a -> [a] -> [a]
: [Location]
locs2)
        mergeDefs (Definition (InR [Location]
locs1)) (Definition (InR [Location]
locs2)) = (Location |? [Location]) -> Definition
Definition ((Location |? [Location]) -> Definition)
-> (Location |? [Location]) -> Definition
forall a b. (a -> b) -> a -> b
$ [Location] -> Location |? [Location]
forall a b. b -> a |? b
InR ([Location]
locs1 [Location] -> [Location] -> [Location]
forall a. [a] -> [a] -> [a]
++ [Location]
locs2)

downgradeLinks :: Definitions -> Definitions
downgradeLinks :: Definitions -> Definitions
downgradeLinks (InR (InL [DefinitionLink]
links)) = Definition -> Definitions
forall a b. a -> a |? b
InL (Definition -> Definitions)
-> ([DefinitionLink] -> Definition)
-> [DefinitionLink]
-> Definitions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Location |? [Location]) -> Definition
Definition ((Location |? [Location]) -> Definition)
-> ([DefinitionLink] -> Location |? [Location])
-> [DefinitionLink]
-> Definition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Location] -> Location |? [Location]
forall a b. b -> a |? b
InR ([Location] -> Location |? [Location])
-> ([DefinitionLink] -> [Location])
-> [DefinitionLink]
-> Location |? [Location]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DefinitionLink -> Location) -> [DefinitionLink] -> [Location]
forall a b. (a -> b) -> [a] -> [b]
map DefinitionLink -> Location
linkToLocation ([DefinitionLink] -> Definitions)
-> [DefinitionLink] -> Definitions
forall a b. (a -> b) -> a -> b
$ [DefinitionLink]
links
    where
        linkToLocation :: DefinitionLink -> Location
        linkToLocation :: DefinitionLink -> Location
linkToLocation (DefinitionLink LocationLink{Uri
$sel:_targetUri:LocationLink :: LocationLink -> Uri
_targetUri :: Uri
_targetUri, Range
$sel:_targetRange:LocationLink :: LocationLink -> Range
_targetRange :: Range
_targetRange}) = Location {$sel:_uri:Location :: Uri
_uri = Uri
_targetUri, $sel:_range:Location :: Range
_range = Range
_targetRange}
downgradeLinks Definitions
defs = Definitions
defs
-- ---------------------------------------------------------------------
-- Plugin Notifications
-- ---------------------------------------------------------------------

-- | Plugin Notification methods. No specific methods at the moment, but
-- might contain more in the future.
class PluginMethod Notification m => PluginNotificationMethod (m :: Method ClientToServer Notification)  where


instance PluginNotificationMethod Method_TextDocumentDidOpen where

instance PluginNotificationMethod Method_TextDocumentDidChange where

instance PluginNotificationMethod Method_TextDocumentDidSave where

instance PluginNotificationMethod Method_TextDocumentDidClose where

instance PluginNotificationMethod Method_WorkspaceDidChangeWatchedFiles where

instance PluginNotificationMethod Method_WorkspaceDidChangeWorkspaceFolders where

instance PluginNotificationMethod Method_WorkspaceDidChangeConfiguration where

instance PluginNotificationMethod Method_Initialized where

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

-- | Methods which have a PluginMethod instance
data IdeMethod (m :: Method ClientToServer Request) = PluginRequestMethod m => IdeMethod (SMethod m)
instance GEq IdeMethod where
  geq :: forall (a :: Method 'ClientToServer 'Request)
       (b :: Method 'ClientToServer 'Request).
IdeMethod a -> IdeMethod b -> Maybe (a :~: b)
geq (IdeMethod SMethod a
a) (IdeMethod SMethod b
b) = SMethod a -> SMethod b -> Maybe (a :~: b)
forall k (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Method 'ClientToServer 'Request)
       (b :: Method 'ClientToServer 'Request).
SMethod a -> SMethod b -> Maybe (a :~: b)
geq SMethod a
a SMethod b
b
instance GCompare IdeMethod where
  gcompare :: forall (a :: Method 'ClientToServer 'Request)
       (b :: Method 'ClientToServer 'Request).
IdeMethod a -> IdeMethod b -> GOrdering a b
gcompare (IdeMethod SMethod a
a) (IdeMethod SMethod b
b) = SMethod a -> SMethod b -> GOrdering a b
forall k (f :: k -> *) (a :: k) (b :: k).
GCompare f =>
f a -> f b -> GOrdering a b
forall (a :: Method 'ClientToServer 'Request)
       (b :: Method 'ClientToServer 'Request).
SMethod a -> SMethod b -> GOrdering a b
gcompare SMethod a
a SMethod b
b

-- | Methods which have a PluginMethod instance
data IdeNotification (m :: Method ClientToServer Notification) = PluginNotificationMethod m => IdeNotification (SMethod m)
instance GEq IdeNotification where
  geq :: forall (a :: Method 'ClientToServer 'Notification)
       (b :: Method 'ClientToServer 'Notification).
IdeNotification a -> IdeNotification b -> Maybe (a :~: b)
geq (IdeNotification SMethod a
a) (IdeNotification SMethod b
b) = SMethod a -> SMethod b -> Maybe (a :~: b)
forall k (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Method 'ClientToServer 'Notification)
       (b :: Method 'ClientToServer 'Notification).
SMethod a -> SMethod b -> Maybe (a :~: b)
geq SMethod a
a SMethod b
b
instance GCompare IdeNotification where
  gcompare :: forall (a :: Method 'ClientToServer 'Notification)
       (b :: Method 'ClientToServer 'Notification).
IdeNotification a -> IdeNotification b -> GOrdering a b
gcompare (IdeNotification SMethod a
a) (IdeNotification SMethod b
b) = SMethod a -> SMethod b -> GOrdering a b
forall k (f :: k -> *) (a :: k) (b :: k).
GCompare f =>
f a -> f b -> GOrdering a b
forall (a :: Method 'ClientToServer 'Notification)
       (b :: Method 'ClientToServer 'Notification).
SMethod a -> SMethod b -> GOrdering a b
gcompare SMethod a
a SMethod b
b

-- | Restricted version of 'LspM' specific to plugins.
--
-- We plan to use this monad for running plugins instead of 'LspM', since there
-- are parts of the LSP server state which plugins should not access directly,
-- but instead only via the build system. Note that this restriction of the LSP
-- server state has not yet been implemented. See 'pluginGetVirtualFile'.
newtype HandlerM config a = HandlerM { forall config a. HandlerM config a -> LspM config a
_runHandlerM :: LspM config a }
  deriving newtype (Functor (HandlerM config)
Functor (HandlerM config) =>
(forall a. a -> HandlerM config a)
-> (forall a b.
    HandlerM config (a -> b) -> HandlerM config a -> HandlerM config b)
-> (forall a b c.
    (a -> b -> c)
    -> HandlerM config a -> HandlerM config b -> HandlerM config c)
-> (forall a b.
    HandlerM config a -> HandlerM config b -> HandlerM config b)
-> (forall a b.
    HandlerM config a -> HandlerM config b -> HandlerM config a)
-> Applicative (HandlerM config)
forall config. Functor (HandlerM config)
forall a. a -> HandlerM config a
forall config a. a -> HandlerM config a
forall a b.
HandlerM config a -> HandlerM config b -> HandlerM config a
forall a b.
HandlerM config a -> HandlerM config b -> HandlerM config b
forall a b.
HandlerM config (a -> b) -> HandlerM config a -> HandlerM config b
forall config a b.
HandlerM config a -> HandlerM config b -> HandlerM config a
forall config a b.
HandlerM config a -> HandlerM config b -> HandlerM config b
forall config a b.
HandlerM config (a -> b) -> HandlerM config a -> HandlerM config b
forall a b c.
(a -> b -> c)
-> HandlerM config a -> HandlerM config b -> HandlerM config c
forall config a b c.
(a -> b -> c)
-> HandlerM config a -> HandlerM config b -> HandlerM config 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 a. a -> HandlerM config a
pure :: forall a. a -> HandlerM config a
$c<*> :: forall config a b.
HandlerM config (a -> b) -> HandlerM config a -> HandlerM config b
<*> :: forall a b.
HandlerM config (a -> b) -> HandlerM config a -> HandlerM config b
$cliftA2 :: forall config a b c.
(a -> b -> c)
-> HandlerM config a -> HandlerM config b -> HandlerM config c
liftA2 :: forall a b c.
(a -> b -> c)
-> HandlerM config a -> HandlerM config b -> HandlerM config c
$c*> :: forall config a b.
HandlerM config a -> HandlerM config b -> HandlerM config b
*> :: forall a b.
HandlerM config a -> HandlerM config b -> HandlerM config b
$c<* :: forall config a b.
HandlerM config a -> HandlerM config b -> HandlerM config a
<* :: forall a b.
HandlerM config a -> HandlerM config b -> HandlerM config a
Applicative, (forall a b. (a -> b) -> HandlerM config a -> HandlerM config b)
-> (forall a b. a -> HandlerM config b -> HandlerM config a)
-> Functor (HandlerM config)
forall a b. a -> HandlerM config b -> HandlerM config a
forall a b. (a -> b) -> HandlerM config a -> HandlerM config b
forall config a b. a -> HandlerM config b -> HandlerM config a
forall config a b.
(a -> b) -> HandlerM config a -> HandlerM config 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 a b.
(a -> b) -> HandlerM config a -> HandlerM config b
fmap :: forall a b. (a -> b) -> HandlerM config a -> HandlerM config b
$c<$ :: forall config a b. a -> HandlerM config b -> HandlerM config a
<$ :: forall a b. a -> HandlerM config b -> HandlerM config a
Functor, Applicative (HandlerM config)
Applicative (HandlerM config) =>
(forall a b.
 HandlerM config a -> (a -> HandlerM config b) -> HandlerM config b)
-> (forall a b.
    HandlerM config a -> HandlerM config b -> HandlerM config b)
-> (forall a. a -> HandlerM config a)
-> Monad (HandlerM config)
forall config. Applicative (HandlerM config)
forall a. a -> HandlerM config a
forall config a. a -> HandlerM config a
forall a b.
HandlerM config a -> HandlerM config b -> HandlerM config b
forall a b.
HandlerM config a -> (a -> HandlerM config b) -> HandlerM config b
forall config a b.
HandlerM config a -> HandlerM config b -> HandlerM config b
forall config a b.
HandlerM config a -> (a -> HandlerM config b) -> HandlerM config 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 a b.
HandlerM config a -> (a -> HandlerM config b) -> HandlerM config b
>>= :: forall a b.
HandlerM config a -> (a -> HandlerM config b) -> HandlerM config b
$c>> :: forall config a b.
HandlerM config a -> HandlerM config b -> HandlerM config b
>> :: forall a b.
HandlerM config a -> HandlerM config b -> HandlerM config b
$creturn :: forall config a. a -> HandlerM config a
return :: forall a. a -> HandlerM config a
Monad, Monad (HandlerM config)
Monad (HandlerM config) =>
(forall a. IO a -> HandlerM config a) -> MonadIO (HandlerM config)
forall config. Monad (HandlerM config)
forall a. IO a -> HandlerM config a
forall config a. IO a -> HandlerM config a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall config a. IO a -> HandlerM config a
liftIO :: forall a. IO a -> HandlerM config a
MonadIO, MonadIO (HandlerM config)
MonadIO (HandlerM config) =>
(forall b.
 ((forall a. HandlerM config a -> IO a) -> IO b)
 -> HandlerM config b)
-> MonadUnliftIO (HandlerM config)
forall config. MonadIO (HandlerM config)
forall b.
((forall a. HandlerM config a -> IO a) -> IO b)
-> HandlerM config b
forall config b.
((forall a. HandlerM config a -> IO a) -> IO b)
-> HandlerM config b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
$cwithRunInIO :: forall config b.
((forall a. HandlerM config a -> IO a) -> IO b)
-> HandlerM config b
withRunInIO :: forall b.
((forall a. HandlerM config a -> IO a) -> IO b)
-> HandlerM config b
MonadUnliftIO)

runHandlerM :: HandlerM config a -> LspM config a
runHandlerM :: forall config a. HandlerM config a -> LspM config a
runHandlerM = HandlerM config a -> LspM config a
forall config a. HandlerM config a -> LspM config a
_runHandlerM

-- | Wrapper of 'getVirtualFile' for HandlerM
--
-- TODO: To be replaced by a lookup of the Shake build graph
pluginGetVirtualFile :: NormalizedUri -> HandlerM config (Maybe VirtualFile)
pluginGetVirtualFile :: forall config. NormalizedUri -> HandlerM config (Maybe VirtualFile)
pluginGetVirtualFile NormalizedUri
uri = LspM config (Maybe VirtualFile)
-> HandlerM config (Maybe VirtualFile)
forall config a. LspM config a -> HandlerM config a
HandlerM (LspM config (Maybe VirtualFile)
 -> HandlerM config (Maybe VirtualFile))
-> LspM config (Maybe VirtualFile)
-> HandlerM config (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ NormalizedUri -> LspM config (Maybe VirtualFile)
forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
getVirtualFile NormalizedUri
uri

-- | Version of 'getVersionedTextDoc' for HandlerM
--
-- TODO: Should use 'pluginGetVirtualFile' instead of wrapping 'getVersionedTextDoc'.
-- At the time of writing, 'getVersionedTextDoc' of the "lsp" package is implemented with 'getVirtualFile'.
pluginGetVersionedTextDoc :: TextDocumentIdentifier -> HandlerM config VersionedTextDocumentIdentifier
pluginGetVersionedTextDoc :: forall config.
TextDocumentIdentifier
-> HandlerM config VersionedTextDocumentIdentifier
pluginGetVersionedTextDoc = LspM config VersionedTextDocumentIdentifier
-> HandlerM config VersionedTextDocumentIdentifier
forall config a. LspM config a -> HandlerM config a
HandlerM (LspM config VersionedTextDocumentIdentifier
 -> HandlerM config VersionedTextDocumentIdentifier)
-> (TextDocumentIdentifier
    -> LspM config VersionedTextDocumentIdentifier)
-> TextDocumentIdentifier
-> HandlerM config VersionedTextDocumentIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextDocumentIdentifier
-> LspM config VersionedTextDocumentIdentifier
forall config (m :: * -> *).
MonadLsp config m =>
TextDocumentIdentifier -> m VersionedTextDocumentIdentifier
getVersionedTextDoc

-- | Wrapper of 'getClientCapabilities' for HandlerM
pluginGetClientCapabilities :: HandlerM config ClientCapabilities
pluginGetClientCapabilities :: forall config. HandlerM config ClientCapabilities
pluginGetClientCapabilities = LspM config ClientCapabilities
-> HandlerM config ClientCapabilities
forall config a. LspM config a -> HandlerM config a
HandlerM LspM config ClientCapabilities
forall config (m :: * -> *).
MonadLsp config m =>
m ClientCapabilities
getClientCapabilities

-- | Wrapper of 'sendNotification for HandlerM
--
-- TODO: Return notification in result instead of calling `sendNotification` directly
pluginSendNotification :: forall (m :: Method ServerToClient Notification) config. SServerMethod m -> MessageParams m -> HandlerM config ()
pluginSendNotification :: forall (m :: Method 'ServerToClient 'Notification) config.
SServerMethod m -> MessageParams m -> HandlerM config ()
pluginSendNotification SServerMethod m
smethod MessageParams m
params = LspM config () -> HandlerM config ()
forall config a. LspM config a -> HandlerM config a
HandlerM (LspM config () -> HandlerM config ())
-> LspM config () -> HandlerM config ()
forall a b. (a -> b) -> a -> b
$ SServerMethod m -> MessageParams m -> LspM config ()
forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
sendNotification SServerMethod m
smethod MessageParams m
params

-- | Wrapper of 'sendRequest' for HandlerM
--
-- TODO: Return request in result instead of calling `sendRequest` directly
pluginSendRequest :: forall (m :: Method ServerToClient Request) config. SServerMethod m -> MessageParams m -> (Either (TResponseError m) (MessageResult m) -> HandlerM config ()) -> HandlerM config (LspId m)
pluginSendRequest :: forall (m :: Method 'ServerToClient 'Request) config.
SServerMethod m
-> MessageParams m
-> (Either (TResponseError m) (MessageResult m)
    -> HandlerM config ())
-> HandlerM config (LspId m)
pluginSendRequest SServerMethod m
smethod MessageParams m
params Either (TResponseError m) (MessageResult m) -> HandlerM config ()
action = LspM config (LspId m) -> HandlerM config (LspId m)
forall config a. LspM config a -> HandlerM config a
HandlerM (LspM config (LspId m) -> HandlerM config (LspId m))
-> LspM config (LspId m) -> HandlerM config (LspId m)
forall a b. (a -> b) -> a -> b
$ SServerMethod m
-> MessageParams m
-> (Either (TResponseError m) (MessageResult m)
    -> LspT config IO ())
-> LspM config (LspId m)
forall (m :: Method 'ServerToClient 'Request) (f :: * -> *) config.
MonadLsp config f =>
SServerMethod m
-> MessageParams m
-> (Either (TResponseError m) (MessageResult m) -> f ())
-> f (LspId m)
sendRequest SServerMethod m
smethod MessageParams m
params (HandlerM config () -> LspT config IO ()
forall config a. HandlerM config a -> LspM config a
runHandlerM (HandlerM config () -> LspT config IO ())
-> (Either (TResponseError m) (MessageResult m)
    -> HandlerM config ())
-> Either (TResponseError m) (MessageResult m)
-> LspT config IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (TResponseError m) (MessageResult m) -> HandlerM config ()
action)

-- | Wrapper of 'withIndefiniteProgress' for HandlerM
pluginWithIndefiniteProgress :: T.Text -> Maybe ProgressToken -> ProgressCancellable -> ((T.Text -> HandlerM config ()) -> HandlerM config a) -> HandlerM config a
pluginWithIndefiniteProgress :: forall config a.
Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((Text -> HandlerM config ()) -> HandlerM config a)
-> HandlerM config a
pluginWithIndefiniteProgress Text
title Maybe ProgressToken
progressToken ProgressCancellable
cancellable (Text -> HandlerM config ()) -> HandlerM config a
updateAction =
  LspM config a -> HandlerM config a
forall config a. LspM config a -> HandlerM config a
HandlerM (LspM config a -> HandlerM config a)
-> LspM config a -> HandlerM config a
forall a b. (a -> b) -> a -> b
$
    Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((Text -> LspT config IO ()) -> LspM config a)
-> LspM config a
forall c (m :: * -> *) a.
MonadLsp c m =>
Text
-> Maybe ProgressToken
-> ProgressCancellable
-> ((Text -> m ()) -> m a)
-> m a
withIndefiniteProgress Text
title Maybe ProgressToken
progressToken ProgressCancellable
cancellable (((Text -> LspT config IO ()) -> LspM config a) -> LspM config a)
-> ((Text -> LspT config IO ()) -> LspM config a) -> LspM config a
forall a b. (a -> b) -> a -> b
$ \Text -> LspT config IO ()
putUpdate ->
      HandlerM config a -> LspM config a
forall config a. HandlerM config a -> LspM config a
runHandlerM (HandlerM config a -> LspM config a)
-> HandlerM config a -> LspM config a
forall a b. (a -> b) -> a -> b
$ (Text -> HandlerM config ()) -> HandlerM config a
updateAction (LspT config IO () -> HandlerM config ()
forall config a. LspM config a -> HandlerM config a
HandlerM (LspT config IO () -> HandlerM config ())
-> (Text -> LspT config IO ()) -> Text -> HandlerM config ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LspT config IO ()
putUpdate)

-- | Combine handlers for the
newtype PluginHandler a (m :: Method ClientToServer Request)
  = PluginHandler (PluginId -> a -> MessageParams m -> HandlerM Config (NonEmpty (Either PluginError (MessageResult m))))

newtype PluginNotificationHandler a (m :: Method ClientToServer Notification)
  = PluginNotificationHandler (PluginId -> a -> VFS -> MessageParams m -> LspM Config ())

newtype PluginHandlers a             = PluginHandlers             (DMap IdeMethod       (PluginHandler a))
newtype PluginNotificationHandlers a = PluginNotificationHandlers (DMap IdeNotification (PluginNotificationHandler a))
instance Semigroup (PluginHandlers a) where
  (PluginHandlers DMap IdeMethod (PluginHandler a)
a) <> :: PluginHandlers a -> PluginHandlers a -> PluginHandlers a
<> (PluginHandlers DMap IdeMethod (PluginHandler a)
b) = DMap IdeMethod (PluginHandler a) -> PluginHandlers a
forall a. DMap IdeMethod (PluginHandler a) -> PluginHandlers a
PluginHandlers (DMap IdeMethod (PluginHandler a) -> PluginHandlers a)
-> DMap IdeMethod (PluginHandler a) -> PluginHandlers a
forall a b. (a -> b) -> a -> b
$ (forall (v :: Method 'ClientToServer 'Request).
 IdeMethod v
 -> PluginHandler a v -> PluginHandler a v -> PluginHandler a v)
-> DMap IdeMethod (PluginHandler a)
-> DMap IdeMethod (PluginHandler a)
-> DMap IdeMethod (PluginHandler a)
forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
GCompare k2 =>
(forall (v :: k1). k2 v -> f v -> f v -> f v)
-> DMap k2 f -> DMap k2 f -> DMap k2 f
DMap.unionWithKey IdeMethod v
-> PluginHandler a v -> PluginHandler a v -> PluginHandler a v
forall (v :: Method 'ClientToServer 'Request).
IdeMethod v
-> PluginHandler a v -> PluginHandler a v -> PluginHandler a v
forall {m :: Method 'ClientToServer 'Request}
       {m :: Method 'ClientToServer 'Request}
       {m :: Method 'ClientToServer 'Request} {p} {a}.
(MessageResult m ~ MessageResult m,
 MessageResult m ~ MessageResult m,
 MessageParams m ~ MessageParams m,
 MessageParams m ~ MessageParams m) =>
p -> PluginHandler a m -> PluginHandler a m -> PluginHandler a m
go DMap IdeMethod (PluginHandler a)
a DMap IdeMethod (PluginHandler a)
b
    where
      go :: p -> PluginHandler a m -> PluginHandler a m -> PluginHandler a m
go p
_ (PluginHandler PluginId
-> a
-> MessageParams m
-> HandlerM
     Config (NonEmpty (Either PluginError (MessageResult m)))
f) (PluginHandler PluginId
-> a
-> MessageParams m
-> HandlerM
     Config (NonEmpty (Either PluginError (MessageResult m)))
g) = (PluginId
 -> a
 -> MessageParams m
 -> HandlerM
      Config (NonEmpty (Either PluginError (MessageResult m))))
-> PluginHandler a m
forall a (m :: Method 'ClientToServer 'Request).
(PluginId
 -> a
 -> MessageParams m
 -> HandlerM
      Config (NonEmpty (Either PluginError (MessageResult m))))
-> PluginHandler a m
PluginHandler ((PluginId
  -> a
  -> MessageParams m
  -> HandlerM
       Config (NonEmpty (Either PluginError (MessageResult m))))
 -> PluginHandler a m)
-> (PluginId
    -> a
    -> MessageParams m
    -> HandlerM
         Config (NonEmpty (Either PluginError (MessageResult m))))
-> PluginHandler a m
forall a b. (a -> b) -> a -> b
$ \PluginId
pid a
ide MessageParams m
params ->
        NonEmpty (Either PluginError (MessageResult m))
-> NonEmpty (Either PluginError (MessageResult m))
-> NonEmpty (Either PluginError (MessageResult m))
forall a. Semigroup a => a -> a -> a
(<>) (NonEmpty (Either PluginError (MessageResult m))
 -> NonEmpty (Either PluginError (MessageResult m))
 -> NonEmpty (Either PluginError (MessageResult m)))
-> HandlerM
     Config (NonEmpty (Either PluginError (MessageResult m)))
-> HandlerM
     Config
     (NonEmpty (Either PluginError (MessageResult m))
      -> NonEmpty (Either PluginError (MessageResult m)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PluginId
-> a
-> MessageParams m
-> HandlerM
     Config (NonEmpty (Either PluginError (MessageResult m)))
f PluginId
pid a
ide MessageParams m
MessageParams m
params HandlerM
  Config
  (NonEmpty (Either PluginError (MessageResult m))
   -> NonEmpty (Either PluginError (MessageResult m)))
-> HandlerM
     Config (NonEmpty (Either PluginError (MessageResult m)))
-> HandlerM
     Config (NonEmpty (Either PluginError (MessageResult m)))
forall a b.
HandlerM Config (a -> b) -> HandlerM Config a -> HandlerM Config b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PluginId
-> a
-> MessageParams m
-> HandlerM
     Config (NonEmpty (Either PluginError (MessageResult m)))
g PluginId
pid a
ide MessageParams m
MessageParams m
params

instance Monoid (PluginHandlers a) where
  mempty :: PluginHandlers a
mempty = DMap IdeMethod (PluginHandler a) -> PluginHandlers a
forall a. DMap IdeMethod (PluginHandler a) -> PluginHandlers a
PluginHandlers DMap IdeMethod (PluginHandler a)
forall a. Monoid a => a
mempty

instance Semigroup (PluginNotificationHandlers a) where
  (PluginNotificationHandlers DMap IdeNotification (PluginNotificationHandler a)
a) <> :: PluginNotificationHandlers a
-> PluginNotificationHandlers a -> PluginNotificationHandlers a
<> (PluginNotificationHandlers DMap IdeNotification (PluginNotificationHandler a)
b) = DMap IdeNotification (PluginNotificationHandler a)
-> PluginNotificationHandlers a
forall a.
DMap IdeNotification (PluginNotificationHandler a)
-> PluginNotificationHandlers a
PluginNotificationHandlers (DMap IdeNotification (PluginNotificationHandler a)
 -> PluginNotificationHandlers a)
-> DMap IdeNotification (PluginNotificationHandler a)
-> PluginNotificationHandlers a
forall a b. (a -> b) -> a -> b
$ (forall (v :: Method 'ClientToServer 'Notification).
 IdeNotification v
 -> PluginNotificationHandler a v
 -> PluginNotificationHandler a v
 -> PluginNotificationHandler a v)
-> DMap IdeNotification (PluginNotificationHandler a)
-> DMap IdeNotification (PluginNotificationHandler a)
-> DMap IdeNotification (PluginNotificationHandler a)
forall {k1} (k2 :: k1 -> *) (f :: k1 -> *).
GCompare k2 =>
(forall (v :: k1). k2 v -> f v -> f v -> f v)
-> DMap k2 f -> DMap k2 f -> DMap k2 f
DMap.unionWithKey IdeNotification v
-> PluginNotificationHandler a v
-> PluginNotificationHandler a v
-> PluginNotificationHandler a v
forall (v :: Method 'ClientToServer 'Notification).
IdeNotification v
-> PluginNotificationHandler a v
-> PluginNotificationHandler a v
-> PluginNotificationHandler a v
forall {m :: Method 'ClientToServer 'Notification}
       {m :: Method 'ClientToServer 'Notification}
       {m :: Method 'ClientToServer 'Notification} {p} {a}.
(MessageParams m ~ MessageParams m,
 MessageParams m ~ MessageParams m) =>
p
-> PluginNotificationHandler a m
-> PluginNotificationHandler a m
-> PluginNotificationHandler a m
go DMap IdeNotification (PluginNotificationHandler a)
a DMap IdeNotification (PluginNotificationHandler a)
b
    where
      go :: p
-> PluginNotificationHandler a m
-> PluginNotificationHandler a m
-> PluginNotificationHandler a m
go p
_ (PluginNotificationHandler PluginId -> a -> VFS -> MessageParams m -> LspM Config ()
f) (PluginNotificationHandler PluginId -> a -> VFS -> MessageParams m -> LspM Config ()
g) = (PluginId -> a -> VFS -> MessageParams m -> LspM Config ())
-> PluginNotificationHandler a m
forall a (m :: Method 'ClientToServer 'Notification).
(PluginId -> a -> VFS -> MessageParams m -> LspM Config ())
-> PluginNotificationHandler a m
PluginNotificationHandler ((PluginId -> a -> VFS -> MessageParams m -> LspM Config ())
 -> PluginNotificationHandler a m)
-> (PluginId -> a -> VFS -> MessageParams m -> LspM Config ())
-> PluginNotificationHandler a m
forall a b. (a -> b) -> a -> b
$ \PluginId
pid a
ide VFS
vfs MessageParams m
params ->
        PluginId -> a -> VFS -> MessageParams m -> LspM Config ()
f PluginId
pid a
ide VFS
vfs MessageParams m
MessageParams m
params LspM Config () -> LspM Config () -> LspM Config ()
forall a b.
LspT Config IO a -> LspT Config IO b -> LspT Config IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PluginId -> a -> VFS -> MessageParams m -> LspM Config ()
g PluginId
pid a
ide VFS
vfs MessageParams m
MessageParams m
params

instance Monoid (PluginNotificationHandlers a) where
  mempty :: PluginNotificationHandlers a
mempty = DMap IdeNotification (PluginNotificationHandler a)
-> PluginNotificationHandlers a
forall a.
DMap IdeNotification (PluginNotificationHandler a)
-> PluginNotificationHandlers a
PluginNotificationHandlers DMap IdeNotification (PluginNotificationHandler a)
forall a. Monoid a => a
mempty

type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> ExceptT PluginError (HandlerM Config) (MessageResult m)

type PluginNotificationMethodHandler a m = a -> VFS -> PluginId -> MessageParams m -> LspM Config ()

-- | Make a handler for plugins. For how resolve works with this see
-- Note [Resolve in PluginHandlers]
mkPluginHandler
  :: forall ideState m. PluginRequestMethod m
  => SClientMethod m
  -> PluginMethodHandler ideState m
  -> PluginHandlers ideState
mkPluginHandler :: forall ideState (m :: Method 'ClientToServer 'Request).
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SClientMethod m
m PluginMethodHandler ideState m
f = DMap IdeMethod (PluginHandler ideState) -> PluginHandlers ideState
forall a. DMap IdeMethod (PluginHandler a) -> PluginHandlers a
PluginHandlers (DMap IdeMethod (PluginHandler ideState)
 -> PluginHandlers ideState)
-> DMap IdeMethod (PluginHandler ideState)
-> PluginHandlers ideState
forall a b. (a -> b) -> a -> b
$ IdeMethod m
-> PluginHandler ideState m
-> DMap IdeMethod (PluginHandler ideState)
forall {k1} (k2 :: k1 -> *) (v :: k1) (f :: k1 -> *).
k2 v -> f v -> DMap k2 f
DMap.singleton (SClientMethod m -> IdeMethod m
forall (m :: Method 'ClientToServer 'Request).
PluginRequestMethod m =>
SMethod m -> IdeMethod m
IdeMethod SClientMethod m
m) ((PluginId
 -> ideState
 -> MessageParams m
 -> HandlerM
      Config (NonEmpty (Either PluginError (MessageResult m))))
-> PluginHandler ideState m
forall a (m :: Method 'ClientToServer 'Request).
(PluginId
 -> a
 -> MessageParams m
 -> HandlerM
      Config (NonEmpty (Either PluginError (MessageResult m))))
-> PluginHandler a m
PluginHandler (SClientMethod m
-> PluginId
-> ideState
-> MessageParams m
-> HandlerM
     Config (NonEmpty (Either PluginError (MessageResult m)))
f' SClientMethod m
m))
  where
    f' :: SMethod m -> PluginId -> ideState -> MessageParams m -> HandlerM Config (NonEmpty (Either PluginError (MessageResult m)))
    -- We need to have separate functions for each method that supports resolve, so far we only support CodeActions
    -- CodeLens, and Completion methods.
    f' :: SClientMethod m
-> PluginId
-> ideState
-> MessageParams m
-> HandlerM
     Config (NonEmpty (Either PluginError (MessageResult m)))
f' SClientMethod m
SMethod_TextDocumentCodeAction PluginId
pid ideState
ide params :: MessageParams m
params@CodeActionParams{$sel:_textDocument:CodeActionParams :: CodeActionParams -> TextDocumentIdentifier
_textDocument=TextDocumentIdentifier {Uri
_uri :: Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri}} =
      Either PluginError ([Command |? CodeAction] |? Null)
-> NonEmpty (Either PluginError ([Command |? CodeAction] |? Null))
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either PluginError ([Command |? CodeAction] |? Null)
 -> NonEmpty (Either PluginError ([Command |? CodeAction] |? Null)))
-> (Either PluginError ([Command |? CodeAction] |? Null)
    -> Either PluginError ([Command |? CodeAction] |? Null))
-> Either PluginError ([Command |? CodeAction] |? Null)
-> NonEmpty (Either PluginError ([Command |? CodeAction] |? Null))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Command |? CodeAction] |? Null)
 -> [Command |? CodeAction] |? Null)
-> Either PluginError ([Command |? CodeAction] |? Null)
-> Either PluginError ([Command |? CodeAction] |? Null)
forall a b.
(a -> b) -> Either PluginError a -> Either PluginError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PluginId
-> Uri
-> ([Command |? CodeAction] |? Null)
-> [Command |? CodeAction] |? Null
forall {f :: * -> *} {b} {a} {b}.
(Functor f, HasData_ b (Maybe Value)) =>
PluginId -> Uri -> (f (a |? b) |? b) -> f (a |? b) |? b
wrapCodeActions PluginId
pid Uri
_uri) (Either PluginError ([Command |? CodeAction] |? Null)
 -> NonEmpty (Either PluginError ([Command |? CodeAction] |? Null)))
-> HandlerM
     Config (Either PluginError ([Command |? CodeAction] |? Null))
-> HandlerM
     Config
     (NonEmpty (Either PluginError ([Command |? CodeAction] |? Null)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT
  PluginError (HandlerM Config) ([Command |? CodeAction] |? Null)
-> HandlerM
     Config (Either PluginError ([Command |? CodeAction] |? Null))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (PluginMethodHandler ideState m
f ideState
ide PluginId
pid MessageParams m
params)
    f' SClientMethod m
SMethod_TextDocumentCodeLens PluginId
pid ideState
ide params :: MessageParams m
params@CodeLensParams{$sel:_textDocument:CodeLensParams :: CodeLensParams -> TextDocumentIdentifier
_textDocument=TextDocumentIdentifier {Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri}} =
      Either PluginError ([CodeLens] |? Null)
-> NonEmpty (Either PluginError ([CodeLens] |? Null))
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either PluginError ([CodeLens] |? Null)
 -> NonEmpty (Either PluginError ([CodeLens] |? Null)))
-> (Either PluginError ([CodeLens] |? Null)
    -> Either PluginError ([CodeLens] |? Null))
-> Either PluginError ([CodeLens] |? Null)
-> NonEmpty (Either PluginError ([CodeLens] |? Null))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([CodeLens] |? Null) -> [CodeLens] |? Null)
-> Either PluginError ([CodeLens] |? Null)
-> Either PluginError ([CodeLens] |? Null)
forall a b.
(a -> b) -> Either PluginError a -> Either PluginError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PluginId -> Uri -> ([CodeLens] |? Null) -> [CodeLens] |? Null
forall {f :: * -> *} {b} {b}.
(Functor f, HasData_ b (Maybe Value)) =>
PluginId -> Uri -> (f b |? b) -> f b |? b
wrapCodeLenses PluginId
pid Uri
_uri) (Either PluginError ([CodeLens] |? Null)
 -> NonEmpty (Either PluginError ([CodeLens] |? Null)))
-> HandlerM Config (Either PluginError ([CodeLens] |? Null))
-> HandlerM
     Config (NonEmpty (Either PluginError ([CodeLens] |? Null)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT PluginError (HandlerM Config) ([CodeLens] |? Null)
-> HandlerM Config (Either PluginError ([CodeLens] |? Null))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (PluginMethodHandler ideState m
f ideState
ide PluginId
pid MessageParams m
params)
    f' SClientMethod m
SMethod_TextDocumentCompletion PluginId
pid ideState
ide params :: MessageParams m
params@CompletionParams{$sel:_textDocument:CompletionParams :: CompletionParams -> TextDocumentIdentifier
_textDocument=TextDocumentIdentifier {Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri}} =
      Either PluginError ([CompletionItem] |? (CompletionList |? Null))
-> NonEmpty
     (Either PluginError ([CompletionItem] |? (CompletionList |? Null)))
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either PluginError ([CompletionItem] |? (CompletionList |? Null))
 -> NonEmpty
      (Either
         PluginError ([CompletionItem] |? (CompletionList |? Null))))
-> (Either
      PluginError ([CompletionItem] |? (CompletionList |? Null))
    -> Either
         PluginError ([CompletionItem] |? (CompletionList |? Null)))
-> Either
     PluginError ([CompletionItem] |? (CompletionList |? Null))
-> NonEmpty
     (Either PluginError ([CompletionItem] |? (CompletionList |? Null)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([CompletionItem] |? (CompletionList |? Null))
 -> [CompletionItem] |? (CompletionList |? Null))
-> Either
     PluginError ([CompletionItem] |? (CompletionList |? Null))
-> Either
     PluginError ([CompletionItem] |? (CompletionList |? Null))
forall a b.
(a -> b) -> Either PluginError a -> Either PluginError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PluginId
-> Uri
-> ([CompletionItem] |? (CompletionList |? Null))
-> [CompletionItem] |? (CompletionList |? Null)
forall {f :: * -> *} {b} {b}.
(Functor f, HasData_ b (Maybe Value)) =>
PluginId
-> Uri
-> (f b |? (CompletionList |? b))
-> f b |? (CompletionList |? b)
wrapCompletions PluginId
pid Uri
_uri) (Either PluginError ([CompletionItem] |? (CompletionList |? Null))
 -> NonEmpty
      (Either
         PluginError ([CompletionItem] |? (CompletionList |? Null))))
-> HandlerM
     Config
     (Either PluginError ([CompletionItem] |? (CompletionList |? Null)))
-> HandlerM
     Config
     (NonEmpty
        (Either
           PluginError ([CompletionItem] |? (CompletionList |? Null))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT
  PluginError
  (HandlerM Config)
  ([CompletionItem] |? (CompletionList |? Null))
-> HandlerM
     Config
     (Either PluginError ([CompletionItem] |? (CompletionList |? Null)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (PluginMethodHandler ideState m
f ideState
ide PluginId
pid MessageParams m
params)

    -- This is the default case for all other methods
    f' SClientMethod m
_ PluginId
pid ideState
ide MessageParams m
params = Either PluginError (MessageResult m)
-> NonEmpty (Either PluginError (MessageResult m))
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either PluginError (MessageResult m)
 -> NonEmpty (Either PluginError (MessageResult m)))
-> HandlerM Config (Either PluginError (MessageResult m))
-> HandlerM
     Config (NonEmpty (Either PluginError (MessageResult m)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT PluginError (HandlerM Config) (MessageResult m)
-> HandlerM Config (Either PluginError (MessageResult m))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (PluginMethodHandler ideState m
f ideState
ide PluginId
pid MessageParams m
params)

    -- Todo: use fancy pancy lenses to make this a few lines
    wrapCodeActions :: PluginId -> Uri -> (f (a |? b) |? b) -> f (a |? b) |? b
wrapCodeActions PluginId
pid Uri
uri (InL f (a |? b)
ls) =
      let wrapCodeActionItem :: PluginId -> Uri -> (a |? b) -> a |? b
wrapCodeActionItem PluginId
pid Uri
uri (InR b
c) = b -> a |? b
forall a b. b -> a |? b
InR (b -> a |? b) -> b -> a |? b
forall a b. (a -> b) -> a -> b
$ PluginId -> Uri -> b -> b
forall a. HasData_ a (Maybe Value) => PluginId -> Uri -> a -> a
wrapResolveData PluginId
pid Uri
uri b
c
          wrapCodeActionItem PluginId
_ Uri
_ command :: a |? b
command@(InL a
_) = a |? b
command
      in f (a |? b) -> f (a |? b) |? b
forall a b. a -> a |? b
InL (f (a |? b) -> f (a |? b) |? b) -> f (a |? b) -> f (a |? b) |? b
forall a b. (a -> b) -> a -> b
$ PluginId -> Uri -> (a |? b) -> a |? b
forall {b} {a}.
HasData_ b (Maybe Value) =>
PluginId -> Uri -> (a |? b) -> a |? b
wrapCodeActionItem PluginId
pid Uri
uri ((a |? b) -> a |? b) -> f (a |? b) -> f (a |? b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a |? b)
ls
    wrapCodeActions PluginId
_ Uri
_ (InR b
r) = b -> f (a |? b) |? b
forall a b. b -> a |? b
InR b
r

    wrapCodeLenses :: PluginId -> Uri -> (f b |? b) -> f b |? b
wrapCodeLenses PluginId
pid Uri
uri (InL f b
ls) = f b -> f b |? b
forall a b. a -> a |? b
InL (f b -> f b |? b) -> f b -> f b |? b
forall a b. (a -> b) -> a -> b
$ PluginId -> Uri -> b -> b
forall a. HasData_ a (Maybe Value) => PluginId -> Uri -> a -> a
wrapResolveData PluginId
pid Uri
uri (b -> b) -> f b -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b
ls
    wrapCodeLenses PluginId
_ Uri
_ (InR b
r)      = b -> f b |? b
forall a b. b -> a |? b
InR b
r

    wrapCompletions :: PluginId
-> Uri
-> (f b |? (CompletionList |? b))
-> f b |? (CompletionList |? b)
wrapCompletions PluginId
pid Uri
uri (InL f b
ls) = f b -> f b |? (CompletionList |? b)
forall a b. a -> a |? b
InL (f b -> f b |? (CompletionList |? b))
-> f b -> f b |? (CompletionList |? b)
forall a b. (a -> b) -> a -> b
$ PluginId -> Uri -> b -> b
forall a. HasData_ a (Maybe Value) => PluginId -> Uri -> a -> a
wrapResolveData PluginId
pid Uri
uri (b -> b) -> f b -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b
ls
    wrapCompletions PluginId
pid Uri
uri (InR (InL cl :: CompletionList
cl@(CompletionList{[CompletionItem]
_items :: [CompletionItem]
$sel:_items:CompletionList :: CompletionList -> [CompletionItem]
_items}))) =
      (CompletionList |? b) -> f b |? (CompletionList |? b)
forall a b. b -> a |? b
InR ((CompletionList |? b) -> f b |? (CompletionList |? b))
-> (CompletionList |? b) -> f b |? (CompletionList |? b)
forall a b. (a -> b) -> a -> b
$ CompletionList -> CompletionList |? b
forall a b. a -> a |? b
InL (CompletionList -> CompletionList |? b)
-> CompletionList -> CompletionList |? b
forall a b. (a -> b) -> a -> b
$ CompletionList
cl CompletionList
-> (CompletionList -> CompletionList) -> CompletionList
forall a b. a -> (a -> b) -> b
& ([CompletionItem] -> Identity [CompletionItem])
-> CompletionList -> Identity CompletionList
forall s a. HasItems s a => Lens' s a
Lens' CompletionList [CompletionItem]
L.items (([CompletionItem] -> Identity [CompletionItem])
 -> CompletionList -> Identity CompletionList)
-> [CompletionItem] -> CompletionList -> CompletionList
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (PluginId -> Uri -> CompletionItem -> CompletionItem
forall a. HasData_ a (Maybe Value) => PluginId -> Uri -> a -> a
wrapResolveData PluginId
pid Uri
uri (CompletionItem -> CompletionItem)
-> [CompletionItem] -> [CompletionItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CompletionItem]
_items)
    wrapCompletions PluginId
_ Uri
_ (InR (InR b
r)) = (CompletionList |? b) -> f b |? (CompletionList |? b)
forall a b. b -> a |? b
InR ((CompletionList |? b) -> f b |? (CompletionList |? b))
-> (CompletionList |? b) -> f b |? (CompletionList |? b)
forall a b. (a -> b) -> a -> b
$ b -> CompletionList |? b
forall a b. b -> a |? b
InR b
r

-- | Make a handler for plugins with no extra data
mkPluginNotificationHandler
  :: PluginNotificationMethod m
  => SClientMethod (m :: Method ClientToServer Notification)
  -> PluginNotificationMethodHandler ideState m
  -> PluginNotificationHandlers ideState
mkPluginNotificationHandler :: forall (m :: Method 'ClientToServer 'Notification) ideState.
PluginNotificationMethod m =>
SClientMethod m
-> PluginNotificationMethodHandler ideState m
-> PluginNotificationHandlers ideState
mkPluginNotificationHandler SClientMethod m
m PluginNotificationMethodHandler ideState m
f
    = DMap IdeNotification (PluginNotificationHandler ideState)
-> PluginNotificationHandlers ideState
forall a.
DMap IdeNotification (PluginNotificationHandler a)
-> PluginNotificationHandlers a
PluginNotificationHandlers (DMap IdeNotification (PluginNotificationHandler ideState)
 -> PluginNotificationHandlers ideState)
-> DMap IdeNotification (PluginNotificationHandler ideState)
-> PluginNotificationHandlers ideState
forall a b. (a -> b) -> a -> b
$ IdeNotification m
-> PluginNotificationHandler ideState m
-> DMap IdeNotification (PluginNotificationHandler ideState)
forall {k1} (k2 :: k1 -> *) (v :: k1) (f :: k1 -> *).
k2 v -> f v -> DMap k2 f
DMap.singleton (SClientMethod m -> IdeNotification m
forall (m :: Method 'ClientToServer 'Notification).
PluginNotificationMethod m =>
SMethod m -> IdeNotification m
IdeNotification SClientMethod m
m) ((PluginId -> ideState -> VFS -> MessageParams m -> LspM Config ())
-> PluginNotificationHandler ideState m
forall a (m :: Method 'ClientToServer 'Notification).
(PluginId -> a -> VFS -> MessageParams m -> LspM Config ())
-> PluginNotificationHandler a m
PluginNotificationHandler PluginId -> ideState -> VFS -> MessageParams m -> LspM Config ()
f')
  where
    f' :: PluginId -> ideState -> VFS -> MessageParams m -> LspM Config ()
f' PluginId
pid ideState
ide VFS
vfs = PluginNotificationMethodHandler ideState m
f ideState
ide VFS
vfs PluginId
pid

defaultPluginPriority :: Natural
defaultPluginPriority :: Natural
defaultPluginPriority = Natural
1000

-- | Set up a plugin descriptor, initialized with default values.
-- This plugin descriptor is prepared for @haskell@ files, such as
--
--   * @.hs@
--   * @.lhs@
--   * @.hs-boot@
--
-- and handlers will be enabled for files with the appropriate file
-- extensions.
defaultPluginDescriptor :: PluginId -> T.Text -> PluginDescriptor ideState
defaultPluginDescriptor :: forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId Text
desc =
  PluginId
-> Text
-> Natural
-> Rules ()
-> [PluginCommand ideState]
-> PluginHandlers ideState
-> ConfigDescriptor
-> PluginNotificationHandlers ideState
-> DynFlagsModifications
-> Maybe (ParserInfo (IdeCommand ideState))
-> [Text]
-> PluginDescriptor ideState
forall ideState.
PluginId
-> Text
-> Natural
-> Rules ()
-> [PluginCommand ideState]
-> PluginHandlers ideState
-> ConfigDescriptor
-> PluginNotificationHandlers ideState
-> DynFlagsModifications
-> Maybe (ParserInfo (IdeCommand ideState))
-> [Text]
-> PluginDescriptor ideState
PluginDescriptor
    PluginId
plId
    Text
desc
    Natural
defaultPluginPriority
    Rules ()
forall a. Monoid a => a
mempty
    [PluginCommand ideState]
forall a. Monoid a => a
mempty
    PluginHandlers ideState
forall a. Monoid a => a
mempty
    ConfigDescriptor
defaultConfigDescriptor
    PluginNotificationHandlers ideState
forall a. Monoid a => a
mempty
    DynFlagsModifications
forall a. Monoid a => a
mempty
    Maybe (ParserInfo (IdeCommand ideState))
forall a. Maybe a
Nothing
    [Text
".hs", Text
".lhs", Text
".hs-boot"]

-- | Set up a plugin descriptor, initialized with default values.
-- This plugin descriptor is prepared for @.cabal@ files and as such,
-- will only respond / run when @.cabal@ files are currently in scope.
--
-- Handles files with the following extensions:
--   * @.cabal@
defaultCabalPluginDescriptor :: PluginId -> T.Text -> PluginDescriptor ideState
defaultCabalPluginDescriptor :: forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultCabalPluginDescriptor PluginId
plId Text
desc =
  PluginId
-> Text
-> Natural
-> Rules ()
-> [PluginCommand ideState]
-> PluginHandlers ideState
-> ConfigDescriptor
-> PluginNotificationHandlers ideState
-> DynFlagsModifications
-> Maybe (ParserInfo (IdeCommand ideState))
-> [Text]
-> PluginDescriptor ideState
forall ideState.
PluginId
-> Text
-> Natural
-> Rules ()
-> [PluginCommand ideState]
-> PluginHandlers ideState
-> ConfigDescriptor
-> PluginNotificationHandlers ideState
-> DynFlagsModifications
-> Maybe (ParserInfo (IdeCommand ideState))
-> [Text]
-> PluginDescriptor ideState
PluginDescriptor
    PluginId
plId
    Text
desc
    Natural
defaultPluginPriority
    Rules ()
forall a. Monoid a => a
mempty
    [PluginCommand ideState]
forall a. Monoid a => a
mempty
    PluginHandlers ideState
forall a. Monoid a => a
mempty
    ConfigDescriptor
defaultConfigDescriptor
    PluginNotificationHandlers ideState
forall a. Monoid a => a
mempty
    DynFlagsModifications
forall a. Monoid a => a
mempty
    Maybe (ParserInfo (IdeCommand ideState))
forall a. Maybe a
Nothing
    [Text
".cabal"]

newtype CommandId = CommandId T.Text
  deriving (Int -> CommandId -> ShowS
[CommandId] -> ShowS
CommandId -> String
(Int -> CommandId -> ShowS)
-> (CommandId -> String)
-> ([CommandId] -> ShowS)
-> Show CommandId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CommandId -> ShowS
showsPrec :: Int -> CommandId -> ShowS
$cshow :: CommandId -> String
show :: CommandId -> String
$cshowList :: [CommandId] -> ShowS
showList :: [CommandId] -> ShowS
Show, ReadPrec [CommandId]
ReadPrec CommandId
Int -> ReadS CommandId
ReadS [CommandId]
(Int -> ReadS CommandId)
-> ReadS [CommandId]
-> ReadPrec CommandId
-> ReadPrec [CommandId]
-> Read CommandId
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS CommandId
readsPrec :: Int -> ReadS CommandId
$creadList :: ReadS [CommandId]
readList :: ReadS [CommandId]
$creadPrec :: ReadPrec CommandId
readPrec :: ReadPrec CommandId
$creadListPrec :: ReadPrec [CommandId]
readListPrec :: ReadPrec [CommandId]
Read, CommandId -> CommandId -> Bool
(CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> Bool) -> Eq CommandId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CommandId -> CommandId -> Bool
== :: CommandId -> CommandId -> Bool
$c/= :: CommandId -> CommandId -> Bool
/= :: CommandId -> CommandId -> Bool
Eq, Eq CommandId
Eq CommandId =>
(CommandId -> CommandId -> Ordering)
-> (CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> CommandId)
-> (CommandId -> CommandId -> CommandId)
-> Ord CommandId
CommandId -> CommandId -> Bool
CommandId -> CommandId -> Ordering
CommandId -> CommandId -> CommandId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CommandId -> CommandId -> Ordering
compare :: CommandId -> CommandId -> Ordering
$c< :: CommandId -> CommandId -> Bool
< :: CommandId -> CommandId -> Bool
$c<= :: CommandId -> CommandId -> Bool
<= :: CommandId -> CommandId -> Bool
$c> :: CommandId -> CommandId -> Bool
> :: CommandId -> CommandId -> Bool
$c>= :: CommandId -> CommandId -> Bool
>= :: CommandId -> CommandId -> Bool
$cmax :: CommandId -> CommandId -> CommandId
max :: CommandId -> CommandId -> CommandId
$cmin :: CommandId -> CommandId -> CommandId
min :: CommandId -> CommandId -> CommandId
Ord)
instance IsString CommandId where
  fromString :: String -> CommandId
fromString = Text -> CommandId
CommandId (Text -> CommandId) -> (String -> Text) -> String -> CommandId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

data PluginCommand ideState = forall a. (FromJSON a) =>
  PluginCommand { forall ideState. PluginCommand ideState -> CommandId
commandId   :: CommandId
                , forall ideState. PluginCommand ideState -> Text
commandDesc :: T.Text
                , ()
commandFunc :: CommandFunction ideState a
                }

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

type CommandFunction ideState a
  = ideState
  -> Maybe ProgressToken
  -> a
  -> ExceptT PluginError (HandlerM Config) (Value |? Null)

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

type ResolveFunction ideState a (m :: Method ClientToServer Request) =
  ideState
  -> PluginId
  -> MessageParams m
  -> Uri
  -> a
  -> ExceptT PluginError (HandlerM Config) (MessageResult m)

-- | Make a handler for resolve methods. In here we take your provided ResolveFunction
-- and turn it into a PluginHandlers. See Note [Resolve in PluginHandlers]
mkResolveHandler
  :: forall ideState a m. (FromJSON a,  PluginRequestMethod m, L.HasData_ (MessageParams m) (Maybe Value))
  =>  SClientMethod m
  -> ResolveFunction ideState a m
  -> PluginHandlers ideState
mkResolveHandler :: forall ideState a (m :: Method 'ClientToServer 'Request).
(FromJSON a, PluginRequestMethod m,
 HasData_ (MessageParams m) (Maybe Value)) =>
SClientMethod m
-> ResolveFunction ideState a m -> PluginHandlers ideState
mkResolveHandler SClientMethod m
m ResolveFunction ideState a m
f = SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
forall ideState (m :: Method 'ClientToServer 'Request).
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SClientMethod m
m (PluginMethodHandler ideState m -> PluginHandlers ideState)
-> PluginMethodHandler ideState m -> PluginHandlers ideState
forall a b. (a -> b) -> a -> b
$ \ideState
ideState PluginId
plId MessageParams m
params -> do
  case Value -> Result PluginResolveData
forall a. FromJSON a => Value -> Result a
fromJSON (Value -> Result PluginResolveData)
-> Maybe Value -> Maybe (Result PluginResolveData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MessageParams m
params MessageParams m
-> Getting (Maybe Value) (MessageParams m) (Maybe Value)
-> Maybe Value
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Value) (MessageParams m) (Maybe Value)
forall s a. HasData_ s a => Lens' s a
Lens' (MessageParams m) (Maybe Value)
L.data_) of
    (Just (Success (PluginResolveData owner :: PluginId
owner@(PluginId Text
ownerName) Uri
uri Value
value) )) -> do
      if PluginId
owner PluginId -> PluginId -> Bool
forall a. Eq a => a -> a -> Bool
== PluginId
plId
      then
        case Value -> Result a
forall a. FromJSON a => Value -> Result a
fromJSON Value
value of
          Success a
decodedValue ->
            let newParams :: MessageParams m
newParams = MessageParams m
params MessageParams m
-> (MessageParams m -> MessageParams m) -> MessageParams m
forall a b. a -> (a -> b) -> b
& (Maybe Value -> Identity (Maybe Value))
-> MessageParams m -> Identity (MessageParams m)
forall s a. HasData_ s a => Lens' s a
Lens' (MessageParams m) (Maybe Value)
L.data_ ((Maybe Value -> Identity (Maybe Value))
 -> MessageParams m -> Identity (MessageParams m))
-> Value -> MessageParams m -> MessageParams m
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Value
value
            in ResolveFunction ideState a m
f ideState
ideState PluginId
plId MessageParams m
newParams Uri
uri a
decodedValue
          Error String
msg ->
            -- We are assuming that if we can't decode the data, that this
            -- request belongs to another resolve handler for this plugin.
            PluginError
-> ExceptT PluginError (HandlerM Config) (MessageResult m)
forall a. PluginError -> ExceptT PluginError (HandlerM Config) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RejectionReason -> PluginError
PluginRequestRefused
                           (Text -> RejectionReason
NotResolveOwner (Text
ownerName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": error decoding payload:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
msg)))
      -- If we are getting an owner that isn't us, this means that there is an
      -- error, as we filter these our in `pluginEnabled`
      else PluginError
-> ExceptT PluginError (HandlerM Config) (MessageResult m)
forall a. PluginError -> ExceptT PluginError (HandlerM Config) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PluginError
 -> ExceptT PluginError (HandlerM Config) (MessageResult m))
-> PluginError
-> ExceptT PluginError (HandlerM Config) (MessageResult m)
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError Text
invalidRequest
    -- If we are getting params without a decodable data field, this means that
    -- there is an error, as we filter these our in `pluginEnabled`
    (Just (Error String
err)) -> PluginError
-> ExceptT PluginError (HandlerM Config) (MessageResult m)
forall a. PluginError -> ExceptT PluginError (HandlerM Config) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PluginError
 -> ExceptT PluginError (HandlerM Config) (MessageResult m))
-> PluginError
-> ExceptT PluginError (HandlerM Config) (MessageResult m)
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError (Maybe Value -> String -> Text
forall {a} {a}. (Show a, Show a) => a -> a -> Text
parseError (MessageParams m
params MessageParams m
-> Getting (Maybe Value) (MessageParams m) (Maybe Value)
-> Maybe Value
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Value) (MessageParams m) (Maybe Value)
forall s a. HasData_ s a => Lens' s a
Lens' (MessageParams m) (Maybe Value)
L.data_) String
err)
    -- If there are no params at all, this also means that there is an error,
    -- as this is filtered out in `pluginEnabled`
    Maybe (Result PluginResolveData)
_ -> PluginError
-> ExceptT PluginError (HandlerM Config) (MessageResult m)
forall a. PluginError -> ExceptT PluginError (HandlerM Config) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PluginError
 -> ExceptT PluginError (HandlerM Config) (MessageResult m))
-> PluginError
-> ExceptT PluginError (HandlerM Config) (MessageResult m)
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError Text
invalidRequest
  where invalidRequest :: Text
invalidRequest = Text
"The resolve request incorrectly got routed to the wrong resolve handler!"
        parseError :: a -> a -> Text
parseError a
value a
err = Text
"Unable to decode: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (a -> String
forall a. Show a => a -> String
show a
value) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (a -> String
forall a. Show a => a -> String
show a
err)

wrapResolveData :: L.HasData_ a (Maybe Value) => PluginId -> Uri -> a -> a
wrapResolveData :: forall a. HasData_ a (Maybe Value) => PluginId -> Uri -> a -> a
wrapResolveData PluginId
pid Uri
uri a
hasData =
  a
hasData a -> (a -> a) -> a
forall a b. a -> (a -> b) -> b
& (Maybe Value -> Identity (Maybe Value)) -> a -> Identity a
forall s a. HasData_ s a => Lens' s a
Lens' a (Maybe Value)
L.data_ ((Maybe Value -> Identity (Maybe Value)) -> a -> Identity a)
-> Maybe Value -> a -> a
forall s t a b. ASetter s t a b -> b -> s -> t
.~  (PluginResolveData -> Value
forall a. ToJSON a => a -> Value
toJSON (PluginResolveData -> Value)
-> (Value -> PluginResolveData) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PluginId -> Uri -> Value -> PluginResolveData
PluginResolveData PluginId
pid Uri
uri (Value -> Value) -> Maybe Value -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Value
data_)
  where data_ :: Maybe Value
data_ = a
hasData a -> Getting (First Value) a Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? (Maybe Value -> Const (First Value) (Maybe Value))
-> a -> Const (First Value) a
forall s a. HasData_ s a => Lens' s a
Lens' a (Maybe Value)
L.data_ ((Maybe Value -> Const (First Value) (Maybe Value))
 -> a -> Const (First Value) a)
-> ((Value -> Const (First Value) Value)
    -> Maybe Value -> Const (First Value) (Maybe Value))
-> Getting (First Value) a Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const (First Value) Value)
-> Maybe Value -> Const (First Value) (Maybe Value)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just

-- |Allow plugins to "own" resolve data, allowing only them to be queried for
-- the resolve action. This design has added flexibility at the cost of nested
-- Value types
data PluginResolveData = PluginResolveData {
  PluginResolveData -> PluginId
resolvePlugin :: PluginId
, PluginResolveData -> Uri
resolveURI    :: Uri
, PluginResolveData -> Value
resolveValue  :: Value
}
  deriving ((forall x. PluginResolveData -> Rep PluginResolveData x)
-> (forall x. Rep PluginResolveData x -> PluginResolveData)
-> Generic PluginResolveData
forall x. Rep PluginResolveData x -> PluginResolveData
forall x. PluginResolveData -> Rep PluginResolveData x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PluginResolveData -> Rep PluginResolveData x
from :: forall x. PluginResolveData -> Rep PluginResolveData x
$cto :: forall x. Rep PluginResolveData x -> PluginResolveData
to :: forall x. Rep PluginResolveData x -> PluginResolveData
Generic, Int -> PluginResolveData -> ShowS
[PluginResolveData] -> ShowS
PluginResolveData -> String
(Int -> PluginResolveData -> ShowS)
-> (PluginResolveData -> String)
-> ([PluginResolveData] -> ShowS)
-> Show PluginResolveData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PluginResolveData -> ShowS
showsPrec :: Int -> PluginResolveData -> ShowS
$cshow :: PluginResolveData -> String
show :: PluginResolveData -> String
$cshowList :: [PluginResolveData] -> ShowS
showList :: [PluginResolveData] -> ShowS
Show)
  deriving anyclass ([PluginResolveData] -> Value
[PluginResolveData] -> Encoding
PluginResolveData -> Bool
PluginResolveData -> Value
PluginResolveData -> Encoding
(PluginResolveData -> Value)
-> (PluginResolveData -> Encoding)
-> ([PluginResolveData] -> Value)
-> ([PluginResolveData] -> Encoding)
-> (PluginResolveData -> Bool)
-> ToJSON PluginResolveData
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: PluginResolveData -> Value
toJSON :: PluginResolveData -> Value
$ctoEncoding :: PluginResolveData -> Encoding
toEncoding :: PluginResolveData -> Encoding
$ctoJSONList :: [PluginResolveData] -> Value
toJSONList :: [PluginResolveData] -> Value
$ctoEncodingList :: [PluginResolveData] -> Encoding
toEncodingList :: [PluginResolveData] -> Encoding
$comitField :: PluginResolveData -> Bool
omitField :: PluginResolveData -> Bool
ToJSON, Maybe PluginResolveData
Value -> Parser [PluginResolveData]
Value -> Parser PluginResolveData
(Value -> Parser PluginResolveData)
-> (Value -> Parser [PluginResolveData])
-> Maybe PluginResolveData
-> FromJSON PluginResolveData
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser PluginResolveData
parseJSON :: Value -> Parser PluginResolveData
$cparseJSONList :: Value -> Parser [PluginResolveData]
parseJSONList :: Value -> Parser [PluginResolveData]
$comittedField :: Maybe PluginResolveData
omittedField :: Maybe PluginResolveData
FromJSON)

newtype PluginId = PluginId T.Text
  deriving (Int -> PluginId -> ShowS
[PluginId] -> ShowS
PluginId -> String
(Int -> PluginId -> ShowS)
-> (PluginId -> String) -> ([PluginId] -> ShowS) -> Show PluginId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PluginId -> ShowS
showsPrec :: Int -> PluginId -> ShowS
$cshow :: PluginId -> String
show :: PluginId -> String
$cshowList :: [PluginId] -> ShowS
showList :: [PluginId] -> ShowS
Show, ReadPrec [PluginId]
ReadPrec PluginId
Int -> ReadS PluginId
ReadS [PluginId]
(Int -> ReadS PluginId)
-> ReadS [PluginId]
-> ReadPrec PluginId
-> ReadPrec [PluginId]
-> Read PluginId
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS PluginId
readsPrec :: Int -> ReadS PluginId
$creadList :: ReadS [PluginId]
readList :: ReadS [PluginId]
$creadPrec :: ReadPrec PluginId
readPrec :: ReadPrec PluginId
$creadListPrec :: ReadPrec [PluginId]
readListPrec :: ReadPrec [PluginId]
Read, PluginId -> PluginId -> Bool
(PluginId -> PluginId -> Bool)
-> (PluginId -> PluginId -> Bool) -> Eq PluginId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PluginId -> PluginId -> Bool
== :: PluginId -> PluginId -> Bool
$c/= :: PluginId -> PluginId -> Bool
/= :: PluginId -> PluginId -> Bool
Eq, Eq PluginId
Eq PluginId =>
(PluginId -> PluginId -> Ordering)
-> (PluginId -> PluginId -> Bool)
-> (PluginId -> PluginId -> Bool)
-> (PluginId -> PluginId -> Bool)
-> (PluginId -> PluginId -> Bool)
-> (PluginId -> PluginId -> PluginId)
-> (PluginId -> PluginId -> PluginId)
-> Ord PluginId
PluginId -> PluginId -> Bool
PluginId -> PluginId -> Ordering
PluginId -> PluginId -> PluginId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PluginId -> PluginId -> Ordering
compare :: PluginId -> PluginId -> Ordering
$c< :: PluginId -> PluginId -> Bool
< :: PluginId -> PluginId -> Bool
$c<= :: PluginId -> PluginId -> Bool
<= :: PluginId -> PluginId -> Bool
$c> :: PluginId -> PluginId -> Bool
> :: PluginId -> PluginId -> Bool
$c>= :: PluginId -> PluginId -> Bool
>= :: PluginId -> PluginId -> Bool
$cmax :: PluginId -> PluginId -> PluginId
max :: PluginId -> PluginId -> PluginId
$cmin :: PluginId -> PluginId -> PluginId
min :: PluginId -> PluginId -> PluginId
Ord)
  deriving newtype ([PluginId] -> Value
[PluginId] -> Encoding
PluginId -> Bool
PluginId -> Value
PluginId -> Encoding
(PluginId -> Value)
-> (PluginId -> Encoding)
-> ([PluginId] -> Value)
-> ([PluginId] -> Encoding)
-> (PluginId -> Bool)
-> ToJSON PluginId
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: PluginId -> Value
toJSON :: PluginId -> Value
$ctoEncoding :: PluginId -> Encoding
toEncoding :: PluginId -> Encoding
$ctoJSONList :: [PluginId] -> Value
toJSONList :: [PluginId] -> Value
$ctoEncodingList :: [PluginId] -> Encoding
toEncodingList :: [PluginId] -> Encoding
$comitField :: PluginId -> Bool
omitField :: PluginId -> Bool
ToJSON, Maybe PluginId
Value -> Parser [PluginId]
Value -> Parser PluginId
(Value -> Parser PluginId)
-> (Value -> Parser [PluginId])
-> Maybe PluginId
-> FromJSON PluginId
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser PluginId
parseJSON :: Value -> Parser PluginId
$cparseJSONList :: Value -> Parser [PluginId]
parseJSONList :: Value -> Parser [PluginId]
$comittedField :: Maybe PluginId
omittedField :: Maybe PluginId
FromJSON, Eq PluginId
Eq PluginId =>
(Int -> PluginId -> Int) -> (PluginId -> Int) -> Hashable PluginId
Int -> PluginId -> Int
PluginId -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> PluginId -> Int
hashWithSalt :: Int -> PluginId -> Int
$chash :: PluginId -> Int
hash :: PluginId -> Int
Hashable)

instance IsString PluginId where
  fromString :: String -> PluginId
fromString = Text -> PluginId
PluginId (Text -> PluginId) -> (String -> Text) -> String -> PluginId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack


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

-- | Format the given Text as a whole or only a @Range@ of it.
-- Range must be relative to the text to format.
-- To format the whole document, read the Text from the file and use 'FormatText'
-- as the FormattingType.
data FormattingType = FormatText
                    | FormatRange Range


type FormattingMethod m =
  ( L.HasOptions (MessageParams m) FormattingOptions
  , L.HasTextDocument (MessageParams m) TextDocumentIdentifier
  , MessageResult m ~ ([TextEdit] |? Null)
  )

type FormattingHandler a
  =  a
  -> Maybe ProgressToken
  -> FormattingType
  -> T.Text
  -> NormalizedFilePath
  -> FormattingOptions
  -> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)

mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a
mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a
mkFormattingHandlers FormattingHandler a
f = SMethod 'Method_TextDocumentFormatting
-> PluginMethodHandler a 'Method_TextDocumentFormatting
-> PluginHandlers a
forall ideState (m :: Method 'ClientToServer 'Request).
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'Method_TextDocumentFormatting
SMethod_TextDocumentFormatting ( SMethod 'Method_TextDocumentFormatting
-> PluginMethodHandler a 'Method_TextDocumentFormatting
forall {f :: MessageDirection} {t :: MessageKind}
       (m :: Method f t).
FormattingMethod m =>
SMethod m -> PluginMethodHandler a m
provider SMethod 'Method_TextDocumentFormatting
SMethod_TextDocumentFormatting)
                      PluginHandlers a -> PluginHandlers a -> PluginHandlers a
forall a. Semigroup a => a -> a -> a
<> SMethod 'Method_TextDocumentRangeFormatting
-> PluginMethodHandler a 'Method_TextDocumentRangeFormatting
-> PluginHandlers a
forall ideState (m :: Method 'ClientToServer 'Request).
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'Method_TextDocumentRangeFormatting
SMethod_TextDocumentRangeFormatting (SMethod 'Method_TextDocumentRangeFormatting
-> PluginMethodHandler a 'Method_TextDocumentRangeFormatting
forall {f :: MessageDirection} {t :: MessageKind}
       (m :: Method f t).
FormattingMethod m =>
SMethod m -> PluginMethodHandler a m
provider SMethod 'Method_TextDocumentRangeFormatting
SMethod_TextDocumentRangeFormatting)
  where
    provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler a m
    provider :: forall {f :: MessageDirection} {t :: MessageKind}
       (m :: Method f t).
FormattingMethod m =>
SMethod m -> PluginMethodHandler a m
provider SMethod m
m a
ide PluginId
_pid MessageParams m
params
      | Just NormalizedFilePath
nfp <- NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath (NormalizedUri -> Maybe NormalizedFilePath)
-> NormalizedUri -> Maybe NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
uri = do
        Maybe VirtualFile
mf <- HandlerM Config (Maybe VirtualFile)
-> ExceptT PluginError (HandlerM Config) (Maybe VirtualFile)
forall (m :: * -> *) a. Monad m => m a -> ExceptT PluginError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (HandlerM Config (Maybe VirtualFile)
 -> ExceptT PluginError (HandlerM Config) (Maybe VirtualFile))
-> HandlerM Config (Maybe VirtualFile)
-> ExceptT PluginError (HandlerM Config) (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ NormalizedUri -> HandlerM Config (Maybe VirtualFile)
forall config. NormalizedUri -> HandlerM config (Maybe VirtualFile)
pluginGetVirtualFile (NormalizedUri -> HandlerM Config (Maybe VirtualFile))
-> NormalizedUri -> HandlerM Config (Maybe VirtualFile)
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
uri
        case Maybe VirtualFile
mf of
          Just VirtualFile
vf -> do
            let (FormattingType
typ, Maybe ProgressToken
mtoken) = case SMethod m
m of
                  SMethod m
SMethod_TextDocumentFormatting -> (FormattingType
FormatText, MessageParams m
DocumentFormattingParams
params DocumentFormattingParams
-> Getting
     (Maybe ProgressToken)
     DocumentFormattingParams
     (Maybe ProgressToken)
-> Maybe ProgressToken
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe ProgressToken)
  DocumentFormattingParams
  (Maybe ProgressToken)
forall s a. HasWorkDoneToken s a => Lens' s a
Lens' DocumentFormattingParams (Maybe ProgressToken)
L.workDoneToken)
                  SMethod m
SMethod_TextDocumentRangeFormatting -> (Range -> FormattingType
FormatRange (MessageParams m
DocumentRangeFormattingParams
params DocumentRangeFormattingParams
-> Getting Range DocumentRangeFormattingParams Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range DocumentRangeFormattingParams Range
forall s a. HasRange s a => Lens' s a
Lens' DocumentRangeFormattingParams Range
L.range), MessageParams m
DocumentRangeFormattingParams
params DocumentRangeFormattingParams
-> Getting
     (Maybe ProgressToken)
     DocumentRangeFormattingParams
     (Maybe ProgressToken)
-> Maybe ProgressToken
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe ProgressToken)
  DocumentRangeFormattingParams
  (Maybe ProgressToken)
forall s a. HasWorkDoneToken s a => Lens' s a
Lens' DocumentRangeFormattingParams (Maybe ProgressToken)
L.workDoneToken)
                  SMethod m
_ -> String -> (FormattingType, Maybe ProgressToken)
forall a. HasCallStack => String -> a
Prelude.error String
"mkFormattingHandlers: impossible"
            FormattingHandler a
f a
ide Maybe ProgressToken
mtoken FormattingType
typ (VirtualFile -> Text
virtualFileText VirtualFile
vf) NormalizedFilePath
nfp FormattingOptions
opts
          Maybe VirtualFile
Nothing -> PluginError
-> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)
forall a. PluginError -> ExceptT PluginError (HandlerM Config) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PluginError
 -> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null))
-> PluginError
-> ExceptT PluginError (HandlerM Config) ([TextEdit] |? Null)
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInvalidParams (Text -> PluginError) -> Text -> PluginError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Formatter plugin: could not get file contents for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Uri -> String
forall a. Show a => a -> String
show Uri
uri

      | Bool
otherwise = PluginError
-> ExceptT PluginError (HandlerM Config) (MessageResult m)
forall a. PluginError -> ExceptT PluginError (HandlerM Config) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PluginError
 -> ExceptT PluginError (HandlerM Config) (MessageResult m))
-> PluginError
-> ExceptT PluginError (HandlerM Config) (MessageResult m)
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInvalidParams (Text -> PluginError) -> Text -> PluginError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Formatter plugin: uriToFilePath failed for: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Uri -> String
forall a. Show a => a -> String
show Uri
uri
      where
        uri :: Uri
uri = MessageParams m
params MessageParams m -> Getting Uri (MessageParams m) Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> MessageParams m -> Const Uri (MessageParams m)
forall s a. HasTextDocument s a => Lens' s a
Lens' (MessageParams m) TextDocumentIdentifier
L.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> MessageParams m -> Const Uri (MessageParams m))
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> Getting Uri (MessageParams m) Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
Lens' TextDocumentIdentifier Uri
L.uri
        opts :: FormattingOptions
opts = MessageParams m
params MessageParams m
-> Getting FormattingOptions (MessageParams m) FormattingOptions
-> FormattingOptions
forall s a. s -> Getting a s a -> a
^. Getting FormattingOptions (MessageParams m) FormattingOptions
forall s a. HasOptions s a => Lens' s a
Lens' (MessageParams m) FormattingOptions
L.options

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


data FallbackCodeActionParams =
  FallbackCodeActionParams
    { FallbackCodeActionParams -> Maybe WorkspaceEdit
fallbackWorkspaceEdit :: Maybe WorkspaceEdit
    , FallbackCodeActionParams -> Maybe Command
fallbackCommand       :: Maybe Command
    }
  deriving ((forall x.
 FallbackCodeActionParams -> Rep FallbackCodeActionParams x)
-> (forall x.
    Rep FallbackCodeActionParams x -> FallbackCodeActionParams)
-> Generic FallbackCodeActionParams
forall x.
Rep FallbackCodeActionParams x -> FallbackCodeActionParams
forall x.
FallbackCodeActionParams -> Rep FallbackCodeActionParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
FallbackCodeActionParams -> Rep FallbackCodeActionParams x
from :: forall x.
FallbackCodeActionParams -> Rep FallbackCodeActionParams x
$cto :: forall x.
Rep FallbackCodeActionParams x -> FallbackCodeActionParams
to :: forall x.
Rep FallbackCodeActionParams x -> FallbackCodeActionParams
Generic, [FallbackCodeActionParams] -> Value
[FallbackCodeActionParams] -> Encoding
FallbackCodeActionParams -> Bool
FallbackCodeActionParams -> Value
FallbackCodeActionParams -> Encoding
(FallbackCodeActionParams -> Value)
-> (FallbackCodeActionParams -> Encoding)
-> ([FallbackCodeActionParams] -> Value)
-> ([FallbackCodeActionParams] -> Encoding)
-> (FallbackCodeActionParams -> Bool)
-> ToJSON FallbackCodeActionParams
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: FallbackCodeActionParams -> Value
toJSON :: FallbackCodeActionParams -> Value
$ctoEncoding :: FallbackCodeActionParams -> Encoding
toEncoding :: FallbackCodeActionParams -> Encoding
$ctoJSONList :: [FallbackCodeActionParams] -> Value
toJSONList :: [FallbackCodeActionParams] -> Value
$ctoEncodingList :: [FallbackCodeActionParams] -> Encoding
toEncodingList :: [FallbackCodeActionParams] -> Encoding
$comitField :: FallbackCodeActionParams -> Bool
omitField :: FallbackCodeActionParams -> Bool
ToJSON, Maybe FallbackCodeActionParams
Value -> Parser [FallbackCodeActionParams]
Value -> Parser FallbackCodeActionParams
(Value -> Parser FallbackCodeActionParams)
-> (Value -> Parser [FallbackCodeActionParams])
-> Maybe FallbackCodeActionParams
-> FromJSON FallbackCodeActionParams
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser FallbackCodeActionParams
parseJSON :: Value -> Parser FallbackCodeActionParams
$cparseJSONList :: Value -> Parser [FallbackCodeActionParams]
parseJSONList :: Value -> Parser [FallbackCodeActionParams]
$comittedField :: Maybe FallbackCodeActionParams
omittedField :: Maybe FallbackCodeActionParams
FromJSON)

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

otSetUri :: SpanInFlight -> Uri -> IO ()
otSetUri :: SpanInFlight -> Uri -> IO ()
otSetUri SpanInFlight
sp (Uri Text
t) = SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"uri" (Text -> ByteString
encodeUtf8 Text
t)

class HasTracing a where
  traceWithSpan :: SpanInFlight -> a -> IO ()
  traceWithSpan SpanInFlight
_ a
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance {-# OVERLAPPABLE #-} (L.HasTextDocument a doc, L.HasUri doc Uri) => HasTracing a where
  traceWithSpan :: SpanInFlight -> a -> IO ()
traceWithSpan SpanInFlight
sp a
a = SpanInFlight -> Uri -> IO ()
otSetUri SpanInFlight
sp (a
a a -> Getting Uri a Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (doc -> Const Uri doc) -> a -> Const Uri a
forall s a. HasTextDocument s a => Lens' s a
Lens' a doc
L.textDocument ((doc -> Const Uri doc) -> a -> Const Uri a)
-> ((Uri -> Const Uri Uri) -> doc -> Const Uri doc)
-> Getting Uri a Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri) -> doc -> Const Uri doc
forall s a. HasUri s a => Lens' s a
Lens' doc Uri
L.uri)

instance HasTracing Value
instance HasTracing ExecuteCommandParams
instance HasTracing DidChangeWatchedFilesParams where
  traceWithSpan :: SpanInFlight -> DidChangeWatchedFilesParams -> IO ()
traceWithSpan SpanInFlight
sp DidChangeWatchedFilesParams{[FileEvent]
_changes :: [FileEvent]
$sel:_changes:DidChangeWatchedFilesParams :: DidChangeWatchedFilesParams -> [FileEvent]
_changes} =
      SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"changes" (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [FileEvent] -> String
forall a. Show a => a -> String
show [FileEvent]
_changes)
instance HasTracing DidChangeWorkspaceFoldersParams
instance HasTracing DidChangeConfigurationParams
instance HasTracing InitializeParams
instance HasTracing InitializedParams
instance HasTracing WorkspaceSymbolParams where
  traceWithSpan :: SpanInFlight -> WorkspaceSymbolParams -> IO ()
traceWithSpan SpanInFlight
sp (WorkspaceSymbolParams Maybe ProgressToken
_ Maybe ProgressToken
_ Text
query) = SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"query" (Text -> ByteString
encodeUtf8 Text
query)
instance HasTracing CallHierarchyIncomingCallsParams
instance HasTracing CallHierarchyOutgoingCallsParams

-- Instances for resolve types
instance HasTracing CodeAction
instance HasTracing CodeLens
instance HasTracing CompletionItem
instance HasTracing DocumentLink
instance HasTracing InlayHint
instance HasTracing WorkspaceSymbol
-- ---------------------------------------------------------------------
--Experimental resolve refactoring
{-# NOINLINE pROCESS_ID #-}
pROCESS_ID :: T.Text
pROCESS_ID :: Text
pROCESS_ID = IO Text -> Text
forall a. IO a -> a
unsafePerformIO IO Text
getPid

mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [Value] -> Command
mkLspCommand :: PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
plid CommandId
cn Text
title Maybe [Value]
args = Text -> Text -> Maybe [Value] -> Command
Command Text
title Text
cmdId Maybe [Value]
args
  where
    cmdId :: Text
cmdId = Text -> PluginId -> CommandId -> Text
mkLspCmdId Text
pROCESS_ID PluginId
plid CommandId
cn

mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text
mkLspCmdId :: Text -> PluginId -> CommandId -> Text
mkLspCmdId Text
pid (PluginId Text
plid) (CommandId Text
cid)
  = Text
pid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
plid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cid

-- | Get the operating system process id for the running server
-- instance. This should be the same for the lifetime of the instance,
-- and different from that of any other currently running instance.
getPid :: IO T.Text
getPid :: IO Text
getPid = String -> Text
T.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> IO Int -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int
getProcessID

getProcessID :: IO Int
installSigUsr1Handler :: IO () -> IO ()

#ifdef mingw32_HOST_OS
getProcessID = fromIntegral <$> P.getCurrentProcessId
installSigUsr1Handler _ = return ()

#else
getProcessID :: IO Int
getProcessID = ProcessID -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ProcessID -> Int) -> IO ProcessID -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ProcessID
P.getProcessID

installSigUsr1Handler :: IO () -> IO ()
installSigUsr1Handler IO ()
h = IO Handler -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Handler -> IO ()) -> IO Handler -> IO ()
forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigUSR1 (IO () -> Handler
Catch IO ()
h) Maybe SignalSet
forall a. Maybe a
Nothing
#endif

{- Note [Resolve in PluginHandlers]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  Resolve methods have a few guarantees that need to be made by HLS,
  specifically they need to only be called once, as neither their errors nor
  their responses can be easily combined. Whereas commands, which similarly have
  the same requirements have their own codepaths for execution, for resolve
  methods we are relying on the standard PluginHandlers codepath.
  That isn't a problem, but it does mean we need to do some things extra for
  these methods.
    - First of all, whenever a handler that can be resolved sets the data_ field
    in their response, we need to intercept it, and wrap it in a data type
    PluginResolveData that allows us to route the future resolve request to the
    specific plugin which is responsible for it. (We also throw in the URI for
    convenience, because everyone needs that). We do that in mkPluginHandler.
    - When we get any resolve requests we check their data field for our
    PluginResolveData that will allow us to route the request to the right
    plugin. If we can't find out which plugin to route the request to, then we
    just don't route it at all. This is done in pluginEnabled, and
    pluginResolverResponsible.
    - Finally we have mkResolveHandler, which takes the resolve request and
    unwraps the plugins data from our PluginResolveData, parses it and passes it
    it on to the registered handler.
  It should be noted that there are some restrictions with this approach: First,
  if a plugin does not set the data_ field, than the request will not be able
  to be resolved. This is because we only wrap data_ fields that have been set
  with our PluginResolvableData tag. Second, if a plugin were to register two
  resolve handlers for the same method, than our assumptions that we never have
  two responses break, and behavior is undefined.
  -}