{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE BlockArguments             #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MonadComprehensions        #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE OverloadedLabels           #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE ViewPatterns               #-}
module Ide.Types
( PluginDescriptor(..), defaultPluginDescriptor, defaultCabalPluginDescriptor
, defaultPluginPriority
, IdeCommand(..)
, IdeMethod(..)
, IdeNotification(..)
, IdePlugins(IdePlugins, ipMap)
, DynFlagsModifications(..)
, Config(..), PluginConfig(..), CheckParents(..)
, ConfigDescriptor(..), defaultConfigDescriptor, configForPlugin, pluginEnabledConfig
, CustomConfig(..), mkCustomConfig
, FallbackCodeActionParams(..)
, FormattingType(..), FormattingMethod, FormattingHandler, mkFormattingHandlers
, HasTracing(..)
, PluginCommand(..), CommandId(..), CommandFunction, mkLspCommand, mkLspCmdId
, PluginId(..)
, PluginHandler(..), mkPluginHandler
, 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, (.~), (?~), (^.), (^?))
import           Control.Monad                 (void)
import           Control.Monad.Error.Class     (MonadError (throwError))
import           Control.Monad.Trans.Class     (MonadTrans (lift))
import           Control.Monad.Trans.Except    (ExceptT, runExceptT)
import           Data.Aeson                    hiding (Null, defaultOptions)
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.Properties
import qualified Language.LSP.Protocol.Lens    as L
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types
import           Language.LSP.Server           (LspM, LspT, getVirtualFile)
import           Language.LSP.VFS
import           Numeric.Natural
import           OpenTelemetry.Eventlog
import           Options.Applicative           (ParserInfo)
import           System.FilePath
import           System.IO.Unsafe
import           Text.Regex.TDFA.Text          ()
-- ---------------------------------------------------------------------

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 $bIdePlugins :: forall ideState. [PluginDescriptor ideState] -> IdePlugins ideState
$mIdePlugins :: forall {r} {ideState}.
IdePlugins ideState
-> ([PluginDescriptor ideState] -> r) -> ((# #) -> r) -> r
IdePlugins{forall ideState. IdePlugins ideState -> [PluginDescriptor ideState]
ipMap} <- IdePlugins_ (sortOn (Down . pluginPriority) . HashMap.elems -> ipMap) _
  where
    IdePlugins [PluginDescriptor ideState]
ipMap = IdePlugins_{ipMap_ :: HashMap PluginId (PluginDescriptor ideState)
ipMap_ = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList forall a b. (a -> b) -> a -> b
$ (forall ideState. PluginDescriptor ideState -> PluginId
pluginId forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. a -> a
id) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PluginDescriptor ideState]
ipMap
                                  , lookupCommandProvider :: CommandId -> Maybe PluginId
lookupCommandProvider = 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) = forall ideState.
HashMap PluginId (PluginDescriptor ideState)
-> (CommandId -> Maybe PluginId) -> IdePlugins ideState
IdePlugins_ (HashMap PluginId (PluginDescriptor a)
a forall a. Semigroup a => a -> a -> a
<> HashMap PluginId (PluginDescriptor a)
b) (\CommandId
x -> CommandId -> Maybe PluginId
f CommandId
x 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 = forall ideState.
HashMap PluginId (PluginDescriptor ideState)
-> (CommandId -> Maybe PluginId) -> IdePlugins ideState
IdePlugins_ forall a. Monoid a => a
mempty (forall a b. a -> b -> a
const 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 = forall ideState. PluginDescriptor ideState -> PluginId
pluginId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall ideState. PluginCommand ideState -> CommandId
commandId (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> DynFlags
g1) (DynFlags -> DynFlags
p2 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 forall a. a -> a
id 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 -> Map PluginId PluginConfig
plugins                 :: !(Map.Map PluginId PluginConfig)
    } deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show,Config -> Config -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c== :: Config -> Config -> Bool
Eq)

instance ToJSON Config where
  toJSON :: Config -> Value
toJSON Config{Bool
Int
Text
Map PluginId PluginConfig
CheckParents
plugins :: Map PluginId PluginConfig
maxCompletions :: Int
cabalFormattingProvider :: Text
formattingProvider :: Text
checkProject :: Bool
checkParents :: CheckParents
plugins :: Config -> Map PluginId PluginConfig
maxCompletions :: Config -> Int
cabalFormattingProvider :: Config -> Text
formattingProvider :: Config -> Text
checkProject :: Config -> Bool
checkParents :: Config -> CheckParents
..} =
      [Pair] -> Value
object [ Key
"haskell" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
r ]
    where
      r :: Value
r = [Pair] -> Value
object [ Key
"checkParents"                forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= CheckParents
checkParents
                 , Key
"checkProject"                forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
checkProject
                 , Key
"formattingProvider"          forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
formattingProvider
                 , Key
"maxCompletions"              forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
maxCompletions
                 , Key
"plugin"                      forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= 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
    { checkParents :: CheckParents
checkParents                = CheckParents
CheckOnSave
    , checkProject :: Bool
checkProject                = Bool
True
    , formattingProvider :: Text
formattingProvider          = Text
"ormolu"
    -- , formattingProvider          = "floskell"
    -- , formattingProvider          = "stylish-haskell"
    , cabalFormattingProvider :: Text
cabalFormattingProvider     = Text
"cabal-fmt"
    -- this string value needs to kept in sync with the value provided in HlsPlugins
    , maxCompletions :: Int
maxCompletions              = Int
40
    , plugins :: Map PluginId PluginConfig
plugins                     = 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CheckParents -> CheckParents -> Bool
$c/= :: CheckParents -> CheckParents -> Bool
== :: CheckParents -> CheckParents -> Bool
$c== :: CheckParents -> CheckParents -> Bool
Eq, Eq 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
min :: CheckParents -> CheckParents -> CheckParents
$cmin :: CheckParents -> CheckParents -> CheckParents
max :: CheckParents -> CheckParents -> CheckParents
$cmax :: CheckParents -> CheckParents -> CheckParents
>= :: CheckParents -> CheckParents -> Bool
$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
compare :: CheckParents -> CheckParents -> Ordering
$ccompare :: CheckParents -> CheckParents -> Ordering
Ord, Int -> CheckParents -> ShowS
[CheckParents] -> ShowS
CheckParents -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CheckParents] -> ShowS
$cshowList :: [CheckParents] -> ShowS
show :: CheckParents -> String
$cshow :: CheckParents -> String
showsPrec :: Int -> CheckParents -> ShowS
$cshowsPrec :: Int -> CheckParents -> ShowS
Show, 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
$cto :: forall x. Rep CheckParents x -> CheckParents
$cfrom :: forall x. CheckParents -> Rep CheckParents x
Generic)
  deriving anyclass (Value -> Parser [CheckParents]
Value -> Parser CheckParents
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [CheckParents]
$cparseJSONList :: Value -> Parser [CheckParents]
parseJSON :: Value -> Parser CheckParents
$cparseJSON :: Value -> Parser CheckParents
FromJSON, [CheckParents] -> Encoding
[CheckParents] -> Value
CheckParents -> Encoding
CheckParents -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CheckParents] -> Encoding
$ctoEncodingList :: [CheckParents] -> Encoding
toJSONList :: [CheckParents] -> Value
$ctoJSONList :: [CheckParents] -> Value
toEncoding :: CheckParents -> Encoding
$ctoEncoding :: CheckParents -> Encoding
toJSON :: CheckParents -> Value
$ctoJSON :: CheckParents -> Value
ToJSON)

-- | 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 -> Object
plcConfig           :: !Object
      } deriving (Int -> PluginConfig -> ShowS
[PluginConfig] -> ShowS
PluginConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PluginConfig] -> ShowS
$cshowList :: [PluginConfig] -> ShowS
show :: PluginConfig -> String
$cshow :: PluginConfig -> String
showsPrec :: Int -> PluginConfig -> ShowS
$cshowsPrec :: Int -> PluginConfig -> ShowS
Show,PluginConfig -> PluginConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PluginConfig -> PluginConfig -> Bool
$c/= :: PluginConfig -> PluginConfig -> Bool
== :: PluginConfig -> PluginConfig -> Bool
$c== :: PluginConfig -> PluginConfig -> Bool
Eq)

instance Default PluginConfig where
  def :: PluginConfig
def = PluginConfig
      { plcGlobalOn :: Bool
plcGlobalOn         = Bool
True
      , plcCallHierarchyOn :: Bool
plcCallHierarchyOn  = Bool
True
      , plcCodeActionsOn :: Bool
plcCodeActionsOn    = Bool
True
      , plcCodeLensOn :: Bool
plcCodeLensOn       = Bool
True
      , plcDiagnosticsOn :: Bool
plcDiagnosticsOn    = Bool
True
      , plcHoverOn :: Bool
plcHoverOn          = Bool
True
      , plcSymbolsOn :: Bool
plcSymbolsOn        = Bool
True
      , plcCompletionOn :: Bool
plcCompletionOn     = Bool
True
      , plcRenameOn :: Bool
plcRenameOn         = Bool
True
      , plcSelectionRangeOn :: Bool
plcSelectionRangeOn = Bool
True
      , plcFoldingRangeOn :: Bool
plcFoldingRangeOn = Bool
True
      , plcConfig :: Object
plcConfig           = 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 Object
cfg) = Value
r
      where
        r :: Value
r = [Pair] -> Value
object [ Key
"globalOn"         forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
g
                   , Key
"callHierarchyOn"  forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
ch
                   , Key
"codeActionsOn"    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
ca
                   , Key
"codeLensOn"       forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
cl
                   , Key
"diagnosticsOn"    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
d
                   , Key
"hoverOn"          forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
h
                   , Key
"symbolsOn"        forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
s
                   , Key
"completionOn"     forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
c
                   , Key
"renameOn"         forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
rn
                   , Key
"selectionRangeOn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
sr
                   , Key
"foldingRangeOn"   forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
fr
                   , Key
"config"           forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Object
cfg
                   ]

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

data PluginDescriptor (ideState :: Type) =
  PluginDescriptor { forall ideState. PluginDescriptor ideState -> PluginId
pluginId           :: !PluginId
                   -- ^ 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 '.'.
                   }

-- | Check whether the given plugin descriptor is responsible for the file with the given path.
--   Compares the file extension of the file at the given path with the file extension
--   the plugin is responsible for.
pluginResponsible :: Uri -> PluginDescriptor c -> Bool
pluginResponsible :: forall c. Uri -> PluginDescriptor c -> Bool
pluginResponsible Uri
uri PluginDescriptor c
pluginDesc
    | Just String
fp <- Maybe String
mfp
    , String -> Text
T.pack (ShowS
takeExtension String
fp) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall ideState. PluginDescriptor ideState -> [Text]
pluginFileType PluginDescriptor c
pluginDesc = Bool
True
    | Bool
otherwise = Bool
False
    where
      mfp :: Maybe String
mfp = Uri -> Maybe String
uriToFilePath Uri
uri

-- | 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 = forall (r :: [PropertyKey]). Properties r -> CustomConfig
CustomConfig

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

-- | 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 enabled.
  -- Perform sanity checks on the message to see whether the plugin is enabled
  -- for this message in particular.
  -- If a plugin is not enabled, its handlers, commands, etc. will not be
  -- run for the given message.
  --
  -- Semantically, this method describes whether a plugin is enabled configuration wise
  -- and is allowed to respond to the message. This might depend on the URI that is
  -- associated to the Message Parameters. There are requests
  -- with no associated URI that, consequentially, cannot inspect the URI.
  --
  -- A common reason why a plugin might not be allowed to respond although 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)
  --
  -- 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.
  pluginEnabled
    :: 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
    -> Bool
    -- ^ Is this plugin enabled and allowed to respond to the given request
    -- with the given parameters?

  default pluginEnabled :: (L.HasTextDocument (MessageParams m) doc, L.HasUri doc Uri)
                              => SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> Bool
  pluginEnabled SMethod m
_ MessageParams m
params PluginDescriptor c
desc Config
conf = forall c. Uri -> PluginDescriptor c -> Bool
pluginResponsible Uri
uri PluginDescriptor c
desc Bool -> Bool -> Bool
&& PluginConfig -> Bool
plcGlobalOn (forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
conf PluginDescriptor c
desc)
    where
        uri :: Uri
uri = MessageParams m
params forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri

-- ---------------------------------------------------------------------
-- 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 = forall a. Semigroup a => NonEmpty a -> a
sconcat

instance PluginMethod Request Method_TextDocumentCodeAction where
  pluginEnabled :: forall c.
SMethod 'Method_TextDocumentCodeAction
-> MessageParams 'Method_TextDocumentCodeAction
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_TextDocumentCodeAction
_ MessageParams 'Method_TextDocumentCodeAction
msgParams PluginDescriptor c
pluginDesc Config
config =
    forall c. Uri -> PluginDescriptor c -> Bool
pluginResponsible Uri
uri PluginDescriptor c
pluginDesc Bool -> Bool -> Bool
&& (PluginConfig -> Bool) -> PluginConfig -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcCodeActionsOn (forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
config PluginDescriptor c
pluginDesc)
    where
      uri :: Uri
uri = MessageParams 'Method_TextDocumentCodeAction
msgParams forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri

instance PluginMethod Request Method_CodeActionResolve where
  -- See Note [Resolve in PluginHandlers]
  pluginEnabled :: forall c.
SMethod 'Method_CodeActionResolve
-> MessageParams 'Method_CodeActionResolve
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_CodeActionResolve
_ MessageParams 'Method_CodeActionResolve
msgParams PluginDescriptor c
pluginDesc Config
config =
    forall c. Maybe Value -> PluginDescriptor c -> Bool
pluginResolverResponsible (MessageParams 'Method_CodeActionResolve
msgParams forall s a. s -> Getting a s a -> a
^. forall s a. HasData_ s a => Lens' s a
L.data_) PluginDescriptor c
pluginDesc
    Bool -> Bool -> Bool
&& (PluginConfig -> Bool) -> PluginConfig -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcCodeActionsOn (forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
config PluginDescriptor c
pluginDesc)

instance PluginMethod Request Method_TextDocumentDefinition where
  pluginEnabled :: forall c.
SMethod 'Method_TextDocumentDefinition
-> MessageParams 'Method_TextDocumentDefinition
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_TextDocumentDefinition
_ MessageParams 'Method_TextDocumentDefinition
msgParams PluginDescriptor c
pluginDesc Config
_ =
    forall c. Uri -> PluginDescriptor c -> Bool
pluginResponsible Uri
uri PluginDescriptor c
pluginDesc
    where
      uri :: Uri
uri = MessageParams 'Method_TextDocumentDefinition
msgParams forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri

instance PluginMethod Request Method_TextDocumentTypeDefinition where
  pluginEnabled :: forall c.
SMethod 'Method_TextDocumentTypeDefinition
-> MessageParams 'Method_TextDocumentTypeDefinition
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_TextDocumentTypeDefinition
_ MessageParams 'Method_TextDocumentTypeDefinition
msgParams PluginDescriptor c
pluginDesc Config
_ =
    forall c. Uri -> PluginDescriptor c -> Bool
pluginResponsible Uri
uri PluginDescriptor c
pluginDesc
    where
      uri :: Uri
uri = MessageParams 'Method_TextDocumentTypeDefinition
msgParams forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri

instance PluginMethod Request Method_TextDocumentDocumentHighlight where
  pluginEnabled :: forall c.
SMethod 'Method_TextDocumentDocumentHighlight
-> MessageParams 'Method_TextDocumentDocumentHighlight
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_TextDocumentDocumentHighlight
_ MessageParams 'Method_TextDocumentDocumentHighlight
msgParams PluginDescriptor c
pluginDesc Config
_ =
    forall c. Uri -> PluginDescriptor c -> Bool
pluginResponsible Uri
uri PluginDescriptor c
pluginDesc
    where
      uri :: Uri
uri = MessageParams 'Method_TextDocumentDocumentHighlight
msgParams forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri

instance PluginMethod Request Method_TextDocumentReferences where
  pluginEnabled :: forall c.
SMethod 'Method_TextDocumentReferences
-> MessageParams 'Method_TextDocumentReferences
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_TextDocumentReferences
_ MessageParams 'Method_TextDocumentReferences
msgParams PluginDescriptor c
pluginDesc Config
_ =
    forall c. Uri -> PluginDescriptor c -> Bool
pluginResponsible Uri
uri PluginDescriptor c
pluginDesc
    where
      uri :: Uri
uri = MessageParams 'Method_TextDocumentReferences
msgParams forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri

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

instance PluginMethod Request Method_TextDocumentCodeLens where
  pluginEnabled :: forall c.
SMethod 'Method_TextDocumentCodeLens
-> MessageParams 'Method_TextDocumentCodeLens
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_TextDocumentCodeLens
_ MessageParams 'Method_TextDocumentCodeLens
msgParams PluginDescriptor c
pluginDesc Config
config = forall c. Uri -> PluginDescriptor c -> Bool
pluginResponsible Uri
uri PluginDescriptor c
pluginDesc
      Bool -> Bool -> Bool
&& (PluginConfig -> Bool) -> PluginConfig -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcCodeLensOn (forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
config PluginDescriptor c
pluginDesc)
    where
      uri :: Uri
uri = MessageParams 'Method_TextDocumentCodeLens
msgParams forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri

instance PluginMethod Request Method_CodeLensResolve where
  -- See Note [Resolve in PluginHandlers]
  pluginEnabled :: forall c.
SMethod 'Method_CodeLensResolve
-> MessageParams 'Method_CodeLensResolve
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_CodeLensResolve
_ MessageParams 'Method_CodeLensResolve
msgParams PluginDescriptor c
pluginDesc Config
config =
    forall c. Maybe Value -> PluginDescriptor c -> Bool
pluginResolverResponsible (MessageParams 'Method_CodeLensResolve
msgParams forall s a. s -> Getting a s a -> a
^. forall s a. HasData_ s a => Lens' s a
L.data_) PluginDescriptor c
pluginDesc
    Bool -> Bool -> Bool
&& (PluginConfig -> Bool) -> PluginConfig -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcCodeActionsOn (forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
config PluginDescriptor c
pluginDesc)

instance PluginMethod Request Method_TextDocumentRename where
  pluginEnabled :: forall c.
SMethod 'Method_TextDocumentRename
-> MessageParams 'Method_TextDocumentRename
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_TextDocumentRename
_ MessageParams 'Method_TextDocumentRename
msgParams PluginDescriptor c
pluginDesc Config
config = forall c. Uri -> PluginDescriptor c -> Bool
pluginResponsible Uri
uri PluginDescriptor c
pluginDesc
      Bool -> Bool -> Bool
&& (PluginConfig -> Bool) -> PluginConfig -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcRenameOn (forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
config PluginDescriptor c
pluginDesc)
   where
      uri :: Uri
uri = MessageParams 'Method_TextDocumentRename
msgParams forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri
instance PluginMethod Request Method_TextDocumentHover where
  pluginEnabled :: forall c.
SMethod 'Method_TextDocumentHover
-> MessageParams 'Method_TextDocumentHover
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_TextDocumentHover
_ MessageParams 'Method_TextDocumentHover
msgParams PluginDescriptor c
pluginDesc Config
config = forall c. Uri -> PluginDescriptor c -> Bool
pluginResponsible Uri
uri PluginDescriptor c
pluginDesc
      Bool -> Bool -> Bool
&& (PluginConfig -> Bool) -> PluginConfig -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcHoverOn (forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
config PluginDescriptor c
pluginDesc)
   where
      uri :: Uri
uri = MessageParams 'Method_TextDocumentHover
msgParams forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri

instance PluginMethod Request Method_TextDocumentDocumentSymbol where
  pluginEnabled :: forall c.
SMethod 'Method_TextDocumentDocumentSymbol
-> MessageParams 'Method_TextDocumentDocumentSymbol
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_TextDocumentDocumentSymbol
_ MessageParams 'Method_TextDocumentDocumentSymbol
msgParams PluginDescriptor c
pluginDesc Config
config = forall c. Uri -> PluginDescriptor c -> Bool
pluginResponsible Uri
uri PluginDescriptor c
pluginDesc
      Bool -> Bool -> Bool
&& (PluginConfig -> Bool) -> PluginConfig -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcSymbolsOn (forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
config PluginDescriptor c
pluginDesc)
    where
      uri :: Uri
uri = MessageParams 'Method_TextDocumentDocumentSymbol
msgParams forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri

instance PluginMethod Request Method_CompletionItemResolve where
  -- See Note [Resolve in PluginHandlers]
  pluginEnabled :: forall c.
SMethod 'Method_CompletionItemResolve
-> MessageParams 'Method_CompletionItemResolve
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_CompletionItemResolve
_ MessageParams 'Method_CompletionItemResolve
msgParams PluginDescriptor c
pluginDesc Config
config = forall c. Maybe Value -> PluginDescriptor c -> Bool
pluginResolverResponsible (MessageParams 'Method_CompletionItemResolve
msgParams forall s a. s -> Getting a s a -> a
^. forall s a. HasData_ s a => Lens' s a
L.data_) PluginDescriptor c
pluginDesc
    Bool -> Bool -> Bool
&& (PluginConfig -> Bool) -> PluginConfig -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcCompletionOn (forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
config PluginDescriptor c
pluginDesc)

instance PluginMethod Request Method_TextDocumentCompletion where
  pluginEnabled :: forall c.
SMethod 'Method_TextDocumentCompletion
-> MessageParams 'Method_TextDocumentCompletion
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_TextDocumentCompletion
_ MessageParams 'Method_TextDocumentCompletion
msgParams PluginDescriptor c
pluginDesc Config
config = forall c. Uri -> PluginDescriptor c -> Bool
pluginResponsible Uri
uri PluginDescriptor c
pluginDesc
      Bool -> Bool -> Bool
&& (PluginConfig -> Bool) -> PluginConfig -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcCompletionOn (forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
config PluginDescriptor c
pluginDesc)
    where
      uri :: Uri
uri = MessageParams 'Method_TextDocumentCompletion
msgParams forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri

instance PluginMethod Request Method_TextDocumentFormatting where
  pluginEnabled :: forall c.
SMethod 'Method_TextDocumentFormatting
-> MessageParams 'Method_TextDocumentFormatting
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_TextDocumentFormatting
SMethod_TextDocumentFormatting MessageParams 'Method_TextDocumentFormatting
msgParams PluginDescriptor c
pluginDesc Config
conf =
    forall c. Uri -> PluginDescriptor c -> Bool
pluginResponsible Uri
uri PluginDescriptor c
pluginDesc
      Bool -> Bool -> Bool
&& (Text -> PluginId
PluginId (Config -> Text
formattingProvider Config
conf) forall a. Eq a => a -> a -> Bool
== PluginId
pid Bool -> Bool -> Bool
|| Text -> PluginId
PluginId (Config -> Text
cabalFormattingProvider Config
conf) forall a. Eq a => a -> a -> Bool
== PluginId
pid)
    where
      uri :: Uri
uri = MessageParams 'Method_TextDocumentFormatting
msgParams forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri
      pid :: PluginId
pid = forall ideState. PluginDescriptor ideState -> PluginId
pluginId PluginDescriptor c
pluginDesc

instance PluginMethod Request Method_TextDocumentRangeFormatting where
  pluginEnabled :: forall c.
SMethod 'Method_TextDocumentRangeFormatting
-> MessageParams 'Method_TextDocumentRangeFormatting
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_TextDocumentRangeFormatting
_ MessageParams 'Method_TextDocumentRangeFormatting
msgParams PluginDescriptor c
pluginDesc Config
conf = forall c. Uri -> PluginDescriptor c -> Bool
pluginResponsible Uri
uri PluginDescriptor c
pluginDesc
      Bool -> Bool -> Bool
&& (Text -> PluginId
PluginId (Config -> Text
formattingProvider Config
conf) forall a. Eq a => a -> a -> Bool
== PluginId
pid Bool -> Bool -> Bool
|| Text -> PluginId
PluginId (Config -> Text
cabalFormattingProvider Config
conf) forall a. Eq a => a -> a -> Bool
== PluginId
pid)
    where
      uri :: Uri
uri = MessageParams 'Method_TextDocumentRangeFormatting
msgParams forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri
      pid :: PluginId
pid = forall ideState. PluginDescriptor ideState -> PluginId
pluginId PluginDescriptor c
pluginDesc

instance PluginMethod Request Method_TextDocumentPrepareCallHierarchy where
  pluginEnabled :: forall c.
SMethod 'Method_TextDocumentPrepareCallHierarchy
-> MessageParams 'Method_TextDocumentPrepareCallHierarchy
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_TextDocumentPrepareCallHierarchy
_ MessageParams 'Method_TextDocumentPrepareCallHierarchy
msgParams PluginDescriptor c
pluginDesc Config
conf = forall c. Uri -> PluginDescriptor c -> Bool
pluginResponsible Uri
uri PluginDescriptor c
pluginDesc
      Bool -> Bool -> Bool
&& (PluginConfig -> Bool) -> PluginConfig -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcCallHierarchyOn (forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
conf PluginDescriptor c
pluginDesc)
    where
      uri :: Uri
uri = MessageParams 'Method_TextDocumentPrepareCallHierarchy
msgParams forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri

instance PluginMethod Request Method_TextDocumentSelectionRange where
  pluginEnabled :: forall c.
SMethod 'Method_TextDocumentSelectionRange
-> MessageParams 'Method_TextDocumentSelectionRange
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_TextDocumentSelectionRange
_ MessageParams 'Method_TextDocumentSelectionRange
msgParams PluginDescriptor c
pluginDesc Config
conf = forall c. Uri -> PluginDescriptor c -> Bool
pluginResponsible Uri
uri PluginDescriptor c
pluginDesc
      Bool -> Bool -> Bool
&& (PluginConfig -> Bool) -> PluginConfig -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcSelectionRangeOn (forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
conf PluginDescriptor c
pluginDesc)
    where
      uri :: Uri
uri = MessageParams 'Method_TextDocumentSelectionRange
msgParams forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri

instance PluginMethod Request Method_TextDocumentFoldingRange where
  pluginEnabled :: forall c.
SMethod 'Method_TextDocumentFoldingRange
-> MessageParams 'Method_TextDocumentFoldingRange
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_TextDocumentFoldingRange
_ MessageParams 'Method_TextDocumentFoldingRange
msgParams PluginDescriptor c
pluginDesc Config
conf = forall c. Uri -> PluginDescriptor c -> Bool
pluginResponsible Uri
uri PluginDescriptor c
pluginDesc
      Bool -> Bool -> Bool
&& (PluginConfig -> Bool) -> PluginConfig -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcFoldingRangeOn (forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
conf PluginDescriptor c
pluginDesc)
    where
      uri :: Uri
uri = MessageParams 'Method_TextDocumentFoldingRange
msgParams forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri

instance PluginMethod Request Method_CallHierarchyIncomingCalls where
  -- This method has no URI parameter, thus no call to 'pluginResponsible'
  pluginEnabled :: forall c.
SMethod 'Method_CallHierarchyIncomingCalls
-> MessageParams 'Method_CallHierarchyIncomingCalls
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_CallHierarchyIncomingCalls
_ MessageParams 'Method_CallHierarchyIncomingCalls
_ PluginDescriptor c
pluginDesc Config
conf = (PluginConfig -> Bool) -> PluginConfig -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcCallHierarchyOn (forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
conf PluginDescriptor c
pluginDesc)

instance PluginMethod Request Method_CallHierarchyOutgoingCalls where
  -- This method has no URI parameter, thus no call to 'pluginResponsible'
  pluginEnabled :: forall c.
SMethod 'Method_CallHierarchyOutgoingCalls
-> MessageParams 'Method_CallHierarchyOutgoingCalls
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_CallHierarchyOutgoingCalls
_ MessageParams 'Method_CallHierarchyOutgoingCalls
_ PluginDescriptor c
pluginDesc Config
conf = (PluginConfig -> Bool) -> PluginConfig -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcCallHierarchyOn (forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
conf PluginDescriptor c
pluginDesc)

instance PluginMethod Request (Method_CustomMethod m) where
  pluginEnabled :: forall c.
SMethod ('Method_CustomMethod m)
-> MessageParams ('Method_CustomMethod m)
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod ('Method_CustomMethod m)
_ MessageParams ('Method_CustomMethod m)
_ PluginDescriptor c
_ Config
_ = Bool
True

---
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 =
      forall a b. a -> a |? b
InL 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 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Command |? CodeAction) -> Bool
wasRequested forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a. (a |? Null) -> Maybe a
nullToMaybe forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
toList NonEmpty (MessageResult 'Method_TextDocumentCodeAction)
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 Rec
  ('R
     '[ "codeActionKind"
        ':-> Rec ('R '[ "valueSet" ':-> [CodeActionKind]])])
_ <- Maybe TextDocumentClientCapabilities
textDocCaps forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TextDocumentClientCapabilities
-> Maybe CodeActionClientCapabilities
_codeAction forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CodeActionClientCapabilities
-> Maybe
     (Rec
        (("codeActionKind"
          .== Rec (("valueSet" .== [CodeActionKind]) .+ Empty))
         .+ Empty))
_codeActionLiteralSupport
        = Command |? CodeAction
x
        | Bool
otherwise = 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 forall s a. s -> Getting a s a -> a
^. forall s a. HasTitle s a => Lens' s a
L.title) (forall a. a -> Maybe a
Just [Value]
cmdParams)
          cmdParams :: [Value]
cmdParams = [forall a. ToJSON a => a -> Value
toJSON (Maybe WorkspaceEdit -> Maybe Command -> FallbackCodeActionParams
FallbackCodeActionParams (CodeAction
action forall s a. s -> Getting a s a -> a
^. forall s a. HasEdit s a => Lens' s a
L.edit) (CodeAction
action forall s a. s -> Getting a s a -> a
^. forall s a. HasCommand s a => Lens' s a
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 forall s a. s -> Getting a s a -> a
^. forall s a. HasKind s a => Lens' s a
L.kind = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\CodeActionKind
k -> CodeActionKind
k 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
_ MessageParams 'Method_TextDocumentDefinition
_ (MessageResult 'Method_TextDocumentDefinition
x :| [MessageResult 'Method_TextDocumentDefinition]
_) = MessageResult 'Method_TextDocumentDefinition
x

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
_ MessageParams 'Method_TextDocumentTypeDefinition
_ (MessageResult 'Method_TextDocumentTypeDefinition
x :| [MessageResult 'Method_TextDocumentTypeDefinition]
_) = MessageResult 'Method_TextDocumentTypeDefinition
x

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 = forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. [a |? b] -> [a]
takeLefts forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
toList NonEmpty (MessageResult 'Method_WorkspaceSymbol)
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_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
_ (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a. (a |? Null) -> Maybe a
nullToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
toList -> [Hover]
hs :: [Hover]) =
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Hover]
hs
        then forall a b. b -> a |? b
InR Null
Null
        else forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ (MarkupContent |? (MarkedString |? [MarkedString]))
-> Maybe Range -> Hover
Hover (forall a b. a -> a |? b
InL MarkupContent
mcontent) Maybe Range
r
    where
      r :: Maybe Range
r = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall s a. s -> Getting a s a -> a
^. forall s a. HasRange s a => Lens' s a
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 = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. [a |? b] -> [a]
takeLefts forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall s a. s -> Getting a s a -> a
^. forall s a. HasContents s a => Lens' s a
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 = [SymbolInformation] |? ([DocumentSymbol] |? Null)
res
    where
      uri' :: Uri
uri' = MessageParams 'Method_TextDocumentDocumentSymbol
params forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri
      supportsHierarchy :: Bool
supportsHierarchy = forall a. a -> Maybe a
Just Bool
True forall a. Eq a => a -> a -> Bool
== (Maybe TextDocumentClientCapabilities
tdc forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TextDocumentClientCapabilities
-> Maybe DocumentSymbolClientCapabilities
_documentSymbol 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 =  forall a b. (a |? b) -> Either a b
toEither forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a |? (b |? Null)) -> Maybe (a |? b)
nullToMaybe' (forall a. NonEmpty a -> [a]
toList NonEmpty (MessageResult 'Method_TextDocumentDocumentSymbol)
xs)
      res :: [SymbolInformation] |? ([DocumentSymbol] |? Null)
      res :: [SymbolInformation] |? ([DocumentSymbol] |? Null)
res
        | Bool
supportsHierarchy = forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SymbolInformation -> DocumentSymbol
siToDs) forall a. a -> a
id) [Either [SymbolInformation] [DocumentSymbol]]
dsOrSi
        | Bool
otherwise = forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id ( 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 forall a. Maybe a
Nothing Maybe Bool
dep Range
range Range
range forall a. Maybe a
Nothing
      dsToSi :: DocumentSymbol -> [SymbolInformation]
dsToSi = Maybe Text -> DocumentSymbol -> [SymbolInformation]
go 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' = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe Text -> DocumentSymbol -> [SymbolInformation]
go (forall a. a -> Maybe a
Just Text
name')) (forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty (DocumentSymbol
ds forall s a. s -> Getting a s a -> a
^. forall s a. HasChildren s a => Lens' s a
L.children))
            loc :: Location
loc = Uri -> Range -> Location
Location Uri
uri' (DocumentSymbol
ds forall s a. s -> Getting a s a -> a
^. forall s a. HasRange s a => Lens' s a
L.range)
            name' :: Text
name' = DocumentSymbol
ds forall s a. s -> Getting a s a -> a
^. forall s a. HasName s a => Lens' s a
L.name
            si :: SymbolInformation
si = Text
-> SymbolKind
-> Maybe [SymbolTag]
-> Maybe Text
-> Maybe Bool
-> Location
-> SymbolInformation
SymbolInformation Text
name' (DocumentSymbol
ds forall s a. s -> Getting a s a -> a
^. forall s a. HasKind s a => Lens' s a
L.kind) forall a. Maybe a
Nothing Maybe Text
parent (DocumentSymbol
ds forall s a. s -> Getting a s a -> a
^. forall s a. HasDeprecated s a => Lens' s a
L.deprecated) Location
loc
        in [SymbolInformation
si] 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
_ (forall a. NonEmpty a -> [a]
toList -> [[CompletionItem] |? (CompletionList |? Null)]
xs) = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Int
-> ([CompletionItem] |? (CompletionList |? Null))
-> (Int, [CompletionItem] |? (CompletionList |? Null))
consumeCompletionResponse Int
limit 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 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 [] =
           forall a b. b -> a |? b
InR (forall a b. a -> a |? b
InL (Bool
-> Maybe
     (Rec
        (("commitCharacters" .== Maybe [Text])
         .+ (("editRange"
              .== Maybe
                    (Range
                     |? Rec (("insert" .== Range) .+ (("replace" .== Range) .+ Empty))))
             .+ (("insertTextFormat" .== Maybe InsertTextFormat)
                 .+ (("insertTextMode" .== Maybe InsertTextMode)
                     .+ (("data" .== Maybe Value) .+ Empty))))))
-> [CompletionItem]
-> CompletionList
CompletionList Bool
comp forall a. Maybe a
Nothing ( 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 forall a. Semigroup a => a -> a -> a
<> 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
  (Rec
     (("commitCharacters" .== Maybe [Text])
      .+ (("editRange"
           .== Maybe
                 (Range
                  |? Rec (("insert" .== Range) .+ (("replace" .== Range) .+ Empty))))
          .+ (("insertTextFormat" .== Maybe InsertTextFormat)
              .+ (("insertTextMode" .== Maybe InsertTextMode)
                  .+ (("data" .== Maybe Value) .+ Empty))))))
_ [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 forall a. Semigroup a => a -> a -> a
<> 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
  (Rec
     (("commitCharacters" .== Maybe [Text])
      .+ (("editRange"
           .== Maybe
                 (Range
                  |? Rec (("insert" .== Range) .+ (("replace" .== Range) .+ Empty))))
          .+ (("insertTextFormat" .== Maybe InsertTextFormat)
              .+ (("insertTextMode" .== Maybe InsertTextMode)
                  .+ (("data" .== Maybe Value) .+ Empty))))))
_ [CompletionItem]
xx))) =
          case forall a. Int -> [a] -> ([a], [a])
splitAt Int
limit [CompletionItem]
xx of
            -- consumed all the items, return the result as is
            ([CompletionItem]
_, []) -> (Int
limit forall a. Num a => a -> a -> a
- 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, forall a b. b -> a |? b
InR (forall a b. a -> a |? b
InL (Bool
-> Maybe
     (Rec
        (("commitCharacters" .== Maybe [Text])
         .+ (("editRange"
              .== Maybe
                    (Range
                     |? Rec (("insert" .== Range) .+ (("replace" .== Range) .+ Empty))))
             .+ (("insertTextFormat" .== Maybe InsertTextFormat)
                 .+ (("insertTextMode" .== Maybe InsertTextMode)
                     .+ (("data" .== Maybe Value) .+ Empty))))))
-> [CompletionItem]
-> CompletionList
CompletionList Bool
isIncompleteResponse forall a. Maybe a
Nothing [CompletionItem]
xx')))
        consumeCompletionResponse Int
n (InL [CompletionItem]
xx) =
          Int
-> ([CompletionItem] |? (CompletionList |? Null))
-> (Int, [CompletionItem] |? (CompletionList |? Null))
consumeCompletionResponse Int
n (forall a b. b -> a |? b
InR (forall a b. a -> a |? b
InL (Bool
-> Maybe
     (Rec
        (("commitCharacters" .== Maybe [Text])
         .+ (("editRange"
              .== Maybe
                    (Range
                     |? Rec (("insert" .== Range) .+ (("replace" .== Range) .+ Empty))))
             .+ (("insertTextFormat" .== Maybe InsertTextFormat)
                 .+ (("insertTextMode" .== Maybe InsertTextMode)
                     .+ (("data" .== Maybe Value) .+ Empty))))))
-> [CompletionItem]
-> CompletionList
CompletionList Bool
isCompleteResponse forall a. Maybe a
Nothing [CompletionItem]
xx)))
        consumeCompletionResponse Int
n (InR (InR Null
Null)) = (Int
n, forall a b. b -> a |? b
InR (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 = forall a. Semigroup a => NonEmpty a -> a
sconcat NonEmpty (MessageResult 'Method_TextDocumentFoldingRange)
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

takeLefts :: [a |? b] -> [a]
takeLefts :: forall a b. [a |? b] -> [a]
takeLefts = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\a |? b
x -> [a
res | (InL a
res) <- 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)       = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL a
x
nullToMaybe' (InR (InL b
x)) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR b
x
nullToMaybe' (InR (InR Null
_)) = forall a. Maybe a
Nothing
-- ---------------------------------------------------------------------
-- 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 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'.
  pluginEnabled :: forall c.
SMethod 'Method_WorkspaceDidChangeWatchedFiles
-> MessageParams 'Method_WorkspaceDidChangeWatchedFiles
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_WorkspaceDidChangeWatchedFiles
_ MessageParams 'Method_WorkspaceDidChangeWatchedFiles
_ PluginDescriptor c
desc Config
conf = PluginConfig -> Bool
plcGlobalOn forall a b. (a -> b) -> a -> b
$ forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
conf PluginDescriptor c
desc

instance PluginMethod Notification Method_WorkspaceDidChangeWorkspaceFolders where
  -- This method has no URI parameter, thus no call to 'pluginResponsible'.
  pluginEnabled :: forall c.
SMethod 'Method_WorkspaceDidChangeWorkspaceFolders
-> MessageParams 'Method_WorkspaceDidChangeWorkspaceFolders
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_WorkspaceDidChangeWorkspaceFolders
_ MessageParams 'Method_WorkspaceDidChangeWorkspaceFolders
_ PluginDescriptor c
desc Config
conf = PluginConfig -> Bool
plcGlobalOn forall a b. (a -> b) -> a -> b
$ forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
conf PluginDescriptor c
desc

instance PluginMethod Notification Method_WorkspaceDidChangeConfiguration where
  -- This method has no URI parameter, thus no call to 'pluginResponsible'.
  pluginEnabled :: forall c.
SMethod 'Method_WorkspaceDidChangeConfiguration
-> MessageParams 'Method_WorkspaceDidChangeConfiguration
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_WorkspaceDidChangeConfiguration
_ MessageParams 'Method_WorkspaceDidChangeConfiguration
_ PluginDescriptor c
desc Config
conf = PluginConfig -> Bool
plcGlobalOn forall a b. (a -> b) -> a -> b
$ forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
conf PluginDescriptor c
desc

instance PluginMethod Notification Method_Initialized where
  -- This method has no URI parameter, thus no call to 'pluginResponsible'.
  pluginEnabled :: forall c.
SMethod 'Method_Initialized
-> MessageParams 'Method_Initialized
-> PluginDescriptor c
-> Config
-> Bool
pluginEnabled SMethod 'Method_Initialized
_ MessageParams 'Method_Initialized
_ PluginDescriptor c
desc Config
conf = PluginConfig -> Bool
plcGlobalOn forall a b. (a -> b) -> a -> b
$ forall c. Config -> PluginDescriptor c -> PluginConfig
configForPlugin Config
conf PluginDescriptor c
desc


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) = forall k (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f 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) = forall k (f :: k -> *) (a :: k) (b :: k).
GCompare f =>
f a -> f 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) = forall k (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f 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) = forall k (f :: k -> *) (a :: k) (b :: k).
GCompare f =>
f a -> f b -> GOrdering a b
gcompare SMethod a
a SMethod b
b

-- | Combine handlers for the
newtype PluginHandler a (m :: Method ClientToServer Request)
  = PluginHandler (PluginId -> a -> MessageParams m -> LspM 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) = forall a. DMap IdeMethod (PluginHandler a) -> PluginHandlers a
PluginHandlers forall a b. (a -> b) -> a -> b
$ 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 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
-> LspM Config (NonEmpty (Either PluginError (MessageResult m)))
f) (PluginHandler PluginId
-> a
-> MessageParams m
-> LspM Config (NonEmpty (Either PluginError (MessageResult m)))
g) = forall a (m :: Method 'ClientToServer 'Request).
(PluginId
 -> a
 -> MessageParams m
 -> LspM Config (NonEmpty (Either PluginError (MessageResult m))))
-> PluginHandler a m
PluginHandler forall a b. (a -> b) -> a -> b
$ \PluginId
pid a
ide MessageParams m
params ->
        forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PluginId
-> a
-> MessageParams m
-> LspM Config (NonEmpty (Either PluginError (MessageResult m)))
f PluginId
pid a
ide MessageParams m
params forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PluginId
-> a
-> MessageParams m
-> LspM Config (NonEmpty (Either PluginError (MessageResult m)))
g PluginId
pid a
ide MessageParams m
params

instance Monoid (PluginHandlers a) where
  mempty :: PluginHandlers a
mempty = forall a. DMap IdeMethod (PluginHandler a) -> PluginHandlers a
PluginHandlers 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) = forall a.
DMap IdeNotification (PluginNotificationHandler a)
-> PluginNotificationHandlers a
PluginNotificationHandlers forall a b. (a -> b) -> a -> b
$ 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 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) = forall a (m :: Method 'ClientToServer 'Notification).
(PluginId -> a -> VFS -> MessageParams m -> LspM Config ())
-> PluginNotificationHandler a m
PluginNotificationHandler 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
params 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
params

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

type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> ExceptT PluginError (LspM 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 = forall a. DMap IdeMethod (PluginHandler a) -> PluginHandlers a
PluginHandlers forall a b. (a -> b) -> a -> b
$ forall {k1} (k2 :: k1 -> *) (v :: k1) (f :: k1 -> *).
k2 v -> f v -> DMap k2 f
DMap.singleton (forall (m :: Method 'ClientToServer 'Request).
PluginRequestMethod m =>
SMethod m -> IdeMethod m
IdeMethod SClientMethod m
m) (forall a (m :: Method 'ClientToServer 'Request).
(PluginId
 -> a
 -> MessageParams m
 -> LspM Config (NonEmpty (Either PluginError (MessageResult m))))
-> PluginHandler a m
PluginHandler (SClientMethod m
-> PluginId
-> ideState
-> MessageParams m
-> LspT Config IO (NonEmpty (Either PluginError (MessageResult m)))
f' SClientMethod m
m))
  where
    f' :: SMethod m -> PluginId -> ideState -> MessageParams m -> LspT Config IO (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
-> LspT Config IO (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
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri}} =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
_uri :: Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri}} =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {f :: * -> *} {b} {b}.
(Functor f, HasData_ b (Maybe Value)) =>
PluginId -> Uri -> (f b |? b) -> f b |? b
wrapCodeLenses PluginId
pid Uri
_uri) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
_uri :: Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri}} =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) = forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> 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 forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ forall {b} {a}.
HasData_ b (Maybe Value) =>
PluginId -> Uri -> (a |? b) -> a |? b
wrapCodeActionItem PluginId
pid Uri
uri forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (a |? b)
ls
    wrapCodeActions PluginId
_ Uri
_ (InR b
r) = 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) = forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ forall a. HasData_ a (Maybe Value) => PluginId -> Uri -> a -> a
wrapResolveData PluginId
pid Uri
uri forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b
ls
    wrapCodeLenses PluginId
_ Uri
_ (InR b
r)      = 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) = forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ forall a. HasData_ a (Maybe Value) => PluginId -> Uri -> a -> a
wrapResolveData PluginId
pid Uri
uri 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]
$sel:_items:CompletionList :: CompletionList -> [CompletionItem]
_items :: [CompletionItem]
_items}))) =
      forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> b
$ forall a b. a -> a |? b
InL forall a b. (a -> b) -> a -> b
$ CompletionList
cl forall a b. a -> (a -> b) -> b
& forall s a. HasItems s a => Lens' s a
L.items forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall a. HasData_ a (Maybe Value) => PluginId -> Uri -> a -> a
wrapResolveData PluginId
pid Uri
uri forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CompletionItem]
_items)
    wrapCompletions PluginId
_ Uri
_ (InR (InR b
r)) = forall a b. b -> a |? b
InR forall a b. (a -> b) -> a -> 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
    = forall a.
DMap IdeNotification (PluginNotificationHandler a)
-> PluginNotificationHandlers a
PluginNotificationHandlers forall a b. (a -> b) -> a -> b
$ forall {k1} (k2 :: k1 -> *) (v :: k1) (f :: k1 -> *).
k2 v -> f v -> DMap k2 f
DMap.singleton (forall (m :: Method 'ClientToServer 'Notification).
PluginNotificationMethod m =>
SMethod m -> IdeNotification m
IdeNotification SClientMethod m
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 -> PluginDescriptor ideState
defaultPluginDescriptor :: forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId =
  forall ideState.
PluginId
-> Natural
-> Rules ()
-> [PluginCommand ideState]
-> PluginHandlers ideState
-> ConfigDescriptor
-> PluginNotificationHandlers ideState
-> DynFlagsModifications
-> Maybe (ParserInfo (IdeCommand ideState))
-> [Text]
-> PluginDescriptor ideState
PluginDescriptor
    PluginId
plId
    Natural
defaultPluginPriority
    forall a. Monoid a => a
mempty
    forall a. Monoid a => a
mempty
    forall a. Monoid a => a
mempty
    ConfigDescriptor
defaultConfigDescriptor
    forall a. Monoid a => a
mempty
    forall a. Monoid a => a
mempty
    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 -> PluginDescriptor ideState
defaultCabalPluginDescriptor :: forall ideState. PluginId -> PluginDescriptor ideState
defaultCabalPluginDescriptor PluginId
plId =
  forall ideState.
PluginId
-> Natural
-> Rules ()
-> [PluginCommand ideState]
-> PluginHandlers ideState
-> ConfigDescriptor
-> PluginNotificationHandlers ideState
-> DynFlagsModifications
-> Maybe (ParserInfo (IdeCommand ideState))
-> [Text]
-> PluginDescriptor ideState
PluginDescriptor
    PluginId
plId
    Natural
defaultPluginPriority
    forall a. Monoid a => a
mempty
    forall a. Monoid a => a
mempty
    forall a. Monoid a => a
mempty
    ConfigDescriptor
defaultConfigDescriptor
    forall a. Monoid a => a
mempty
    forall a. Monoid a => a
mempty
    forall a. Maybe a
Nothing
    [Text
".cabal"]

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

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

type ResolveFunction ideState a (m :: Method ClientToServer Request) =
  ideState
  -> PluginId
  -> MessageParams m
  -> Uri
  -> a
  -> ExceptT PluginError (LspM 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 = forall ideState (m :: Method 'ClientToServer 'Request).
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SClientMethod m
m forall a b. (a -> b) -> a -> b
$ \ideState
ideState PluginId
plId MessageParams m
params -> do
  case forall a. FromJSON a => Value -> Result a
fromJSON forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MessageParams m
params forall s a. s -> Getting a s a -> a
^. forall s a. HasData_ s a => Lens' s a
L.data_) of
    (Just (Success (PluginResolveData PluginId
owner Uri
uri Value
value) )) -> do
      if PluginId
owner forall a. Eq a => a -> a -> Bool
== PluginId
plId
      then
        case forall a. FromJSON a => Value -> Result a
fromJSON Value
value of
          Success a
decodedValue ->
            let newParams :: MessageParams m
newParams = MessageParams m
params forall a b. a -> (a -> b) -> b
& forall s a. HasData_ s a => Lens' s a
L.data_ 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.
            forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> PluginError
PluginRequestRefused (String -> Text
T.pack (String
"Unable to decode payload for handler, assuming that it's for a different handler" forall a. Semigroup a => a -> a -> a
<> 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 forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError 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)) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInternalError (forall {a} {a}. (Show a, Show a) => a -> a -> Text
parseError (MessageParams m
params forall s a. s -> Getting a s a -> a
^. forall s a. HasData_ s a => Lens' s a
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)
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError 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: " forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show a
value) forall a. Semigroup a => a -> a -> a
<> Text
". Error: " forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ 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 forall a b. a -> (a -> b) -> b
& forall s a. HasData_ s a => Lens' s a
L.data_ forall s t a b. ASetter s t a b -> b -> s -> t
.~  (forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. PluginId -> Uri -> Value -> PluginResolveData
PluginResolveData PluginId
pid Uri
uri forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Value
data_)
  where data_ :: Maybe Value
data_ = a
hasData forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. HasData_ s a => Lens' s a
L.data_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a 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. 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
$cto :: forall x. Rep PluginResolveData x -> PluginResolveData
$cfrom :: forall x. PluginResolveData -> Rep PluginResolveData x
Generic, Int -> PluginResolveData -> ShowS
[PluginResolveData] -> ShowS
PluginResolveData -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PluginResolveData] -> ShowS
$cshowList :: [PluginResolveData] -> ShowS
show :: PluginResolveData -> String
$cshow :: PluginResolveData -> String
showsPrec :: Int -> PluginResolveData -> ShowS
$cshowsPrec :: Int -> PluginResolveData -> ShowS
Show)
  deriving anyclass ([PluginResolveData] -> Encoding
[PluginResolveData] -> Value
PluginResolveData -> Encoding
PluginResolveData -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [PluginResolveData] -> Encoding
$ctoEncodingList :: [PluginResolveData] -> Encoding
toJSONList :: [PluginResolveData] -> Value
$ctoJSONList :: [PluginResolveData] -> Value
toEncoding :: PluginResolveData -> Encoding
$ctoEncoding :: PluginResolveData -> Encoding
toJSON :: PluginResolveData -> Value
$ctoJSON :: PluginResolveData -> Value
ToJSON, Value -> Parser [PluginResolveData]
Value -> Parser PluginResolveData
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [PluginResolveData]
$cparseJSONList :: Value -> Parser [PluginResolveData]
parseJSON :: Value -> Parser PluginResolveData
$cparseJSON :: Value -> Parser PluginResolveData
FromJSON)

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

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

-- | 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))
Rules ()
PluginId
PluginNotificationHandlers c
PluginHandlers c
ConfigDescriptor
DynFlagsModifications
pluginFileType :: [Text]
pluginCli :: Maybe (ParserInfo (IdeCommand c))
pluginModifyDynflags :: DynFlagsModifications
pluginNotificationHandlers :: PluginNotificationHandlers c
pluginConfigDescriptor :: ConfigDescriptor
pluginHandlers :: PluginHandlers c
pluginCommands :: [PluginCommand c]
pluginRules :: Rules ()
pluginPriority :: Natural
pluginId :: PluginId
pluginFileType :: forall ideState. PluginDescriptor ideState -> [Text]
pluginCli :: forall ideState.
PluginDescriptor ideState
-> Maybe (ParserInfo (IdeCommand ideState))
pluginModifyDynflags :: forall ideState. PluginDescriptor ideState -> DynFlagsModifications
pluginNotificationHandlers :: forall ideState.
PluginDescriptor ideState -> PluginNotificationHandlers ideState
pluginConfigDescriptor :: forall ideState. PluginDescriptor ideState -> ConfigDescriptor
pluginHandlers :: forall ideState.
PluginDescriptor ideState -> PluginHandlers ideState
pluginRules :: forall ideState. PluginDescriptor ideState -> Rules ()
pluginCommands :: forall ideState.
PluginDescriptor ideState -> [PluginCommand ideState]
pluginId :: forall ideState. PluginDescriptor ideState -> PluginId
pluginPriority :: forall ideState. PluginDescriptor ideState -> Natural
..}
    = 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 given plugin is both enabled and the specific feature is
-- enabled
pluginEnabledConfig :: (PluginConfig -> Bool) -> PluginConfig -> Bool
pluginEnabledConfig :: (PluginConfig -> Bool) -> PluginConfig -> Bool
pluginEnabledConfig PluginConfig -> Bool
f PluginConfig
pluginConfig = PluginConfig -> Bool
plcGlobalOn PluginConfig
pluginConfig Bool -> Bool -> Bool
&& PluginConfig -> Bool
f PluginConfig
pluginConfig

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

-- | 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
  -> FormattingType
  -> T.Text
  -> NormalizedFilePath
  -> FormattingOptions
  -> ExceptT PluginError (LspM Config) ([TextEdit] |? Null)

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

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

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


data FallbackCodeActionParams =
  FallbackCodeActionParams
    { FallbackCodeActionParams -> Maybe WorkspaceEdit
fallbackWorkspaceEdit :: Maybe WorkspaceEdit
    , FallbackCodeActionParams -> Maybe Command
fallbackCommand       :: Maybe Command
    }
  deriving (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
$cto :: forall x.
Rep FallbackCodeActionParams x -> FallbackCodeActionParams
$cfrom :: forall x.
FallbackCodeActionParams -> Rep FallbackCodeActionParams x
Generic, [FallbackCodeActionParams] -> Encoding
[FallbackCodeActionParams] -> Value
FallbackCodeActionParams -> Encoding
FallbackCodeActionParams -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [FallbackCodeActionParams] -> Encoding
$ctoEncodingList :: [FallbackCodeActionParams] -> Encoding
toJSONList :: [FallbackCodeActionParams] -> Value
$ctoJSONList :: [FallbackCodeActionParams] -> Value
toEncoding :: FallbackCodeActionParams -> Encoding
$ctoEncoding :: FallbackCodeActionParams -> Encoding
toJSON :: FallbackCodeActionParams -> Value
$ctoJSON :: FallbackCodeActionParams -> Value
ToJSON, Value -> Parser [FallbackCodeActionParams]
Value -> Parser FallbackCodeActionParams
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [FallbackCodeActionParams]
$cparseJSONList :: Value -> Parser [FallbackCodeActionParams]
parseJSON :: Value -> Parser FallbackCodeActionParams
$cparseJSON :: Value -> Parser FallbackCodeActionParams
FromJSON)

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

otSetUri :: SpanInFlight -> Uri -> IO ()
otSetUri :: SpanInFlight -> Uri -> IO ()
otSetUri SpanInFlight
sp (Uri Text
t) = 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
_ = 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 forall s a. s -> Getting a s a -> a
^. forall s a. HasTextDocument s a => Lens' s a
L.textDocument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
L.uri)

instance HasTracing Value
instance HasTracing ExecuteCommandParams
instance HasTracing DidChangeWatchedFilesParams where
  traceWithSpan :: SpanInFlight -> DidChangeWatchedFilesParams -> IO ()
traceWithSpan SpanInFlight
sp DidChangeWatchedFilesParams{[FileEvent]
$sel:_changes:DidChangeWatchedFilesParams :: DidChangeWatchedFilesParams -> [FileEvent]
_changes :: [FileEvent]
_changes} =
      forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"changes" (Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ 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) = 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 = 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 forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> Text
plid forall a. Semigroup a => a -> a -> a
<> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ProcessID
P.getProcessID

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

-- |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 :: Maybe Value -> PluginDescriptor c -> Bool
pluginResolverResponsible :: forall c. Maybe Value -> PluginDescriptor c -> Bool
pluginResolverResponsible (Just (forall a. FromJSON a => Value -> Result a
fromJSON -> (Success (PluginResolveData PluginId
o Uri
_ Value
_)))) PluginDescriptor c
pluginDesc =
  forall ideState. PluginDescriptor ideState -> PluginId
pluginId PluginDescriptor c
pluginDesc forall a. Eq a => a -> a -> Bool
== PluginId
o
-- We want to fail closed
pluginResolverResponsible Maybe Value
_ PluginDescriptor c
_ = Bool
False

{- 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.
  -}