{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE ViewPatterns               #-}

module Ide.Types
    where

#ifdef mingw32_HOST_OS
import qualified System.Win32.Process            as P (getCurrentProcessId)
#else
import           Control.Monad                   (void)
import qualified System.Posix.Process            as P (getProcessID)
import           System.Posix.Signals
#endif
import           Control.Lens                    ((^.))
import           Data.Aeson                      hiding (defaultOptions)
import qualified Data.DList                      as DList
import qualified Data.Default
import           Data.Dependent.Map              (DMap)
import qualified Data.Dependent.Map              as DMap
import           Data.GADT.Compare
import           Data.List.NonEmpty              (NonEmpty (..), toList)
import qualified Data.Map                        as Map
import           Data.Maybe
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.Config
import           Ide.Plugin.Properties
import           Language.LSP.Server             (LspM, getVirtualFile)
import           Language.LSP.Types              hiding
                                                 (SemanticTokenAbsolute (length, line),
                                                  SemanticTokenRelative (length),
                                                  SemanticTokensEdit (_start))
import           Language.LSP.Types.Capabilities (ClientCapabilities (ClientCapabilities),
                                                  TextDocumentClientCapabilities (_codeAction, _documentSymbol))
import           Language.LSP.Types.Lens         as J (HasChildren (children),
                                                       HasCommand (command),
                                                       HasContents (contents),
                                                       HasDeprecated (deprecated),
                                                       HasEdit (edit),
                                                       HasKind (kind),
                                                       HasName (name),
                                                       HasOptions (..),
                                                       HasRange (range),
                                                       HasTextDocument (..),
                                                       HasTitle (title),
                                                       HasUri (..))
import           Language.LSP.VFS
import           OpenTelemetry.Eventlog
import           Options.Applicative             (ParserInfo)
import           System.IO.Unsafe
import           Text.Regex.TDFA.Text            ()

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

newtype IdePlugins ideState = IdePlugins
  { IdePlugins ideState -> [(PluginId, PluginDescriptor ideState)]
ipMap :: [(PluginId, PluginDescriptor ideState)]}
  deriving newtype (Semigroup (IdePlugins ideState)
IdePlugins ideState
Semigroup (IdePlugins ideState)
-> IdePlugins ideState
-> (IdePlugins ideState
    -> IdePlugins ideState -> IdePlugins ideState)
-> ([IdePlugins ideState] -> IdePlugins ideState)
-> Monoid (IdePlugins ideState)
[IdePlugins ideState] -> IdePlugins ideState
IdePlugins ideState -> IdePlugins ideState -> IdePlugins ideState
forall ideState. Semigroup (IdePlugins ideState)
forall ideState. IdePlugins ideState
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall ideState. [IdePlugins ideState] -> IdePlugins ideState
forall ideState.
IdePlugins ideState -> IdePlugins ideState -> IdePlugins ideState
mconcat :: [IdePlugins ideState] -> IdePlugins ideState
$cmconcat :: forall ideState. [IdePlugins ideState] -> IdePlugins ideState
mappend :: IdePlugins ideState -> IdePlugins ideState -> IdePlugins ideState
$cmappend :: forall ideState.
IdePlugins ideState -> IdePlugins ideState -> IdePlugins ideState
mempty :: IdePlugins ideState
$cmempty :: forall ideState. IdePlugins ideState
$cp1Monoid :: forall ideState. Semigroup (IdePlugins ideState)
Monoid, b -> IdePlugins ideState -> IdePlugins ideState
NonEmpty (IdePlugins ideState) -> IdePlugins ideState
IdePlugins ideState -> IdePlugins ideState -> IdePlugins ideState
(IdePlugins ideState -> IdePlugins ideState -> IdePlugins ideState)
-> (NonEmpty (IdePlugins ideState) -> IdePlugins ideState)
-> (forall b.
    Integral b =>
    b -> IdePlugins ideState -> IdePlugins ideState)
-> Semigroup (IdePlugins ideState)
forall b.
Integral b =>
b -> IdePlugins ideState -> IdePlugins ideState
forall ideState.
NonEmpty (IdePlugins ideState) -> IdePlugins ideState
forall ideState.
IdePlugins ideState -> IdePlugins ideState -> IdePlugins ideState
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall ideState b.
Integral b =>
b -> IdePlugins ideState -> IdePlugins ideState
stimes :: b -> IdePlugins ideState -> IdePlugins ideState
$cstimes :: forall ideState b.
Integral b =>
b -> IdePlugins ideState -> IdePlugins ideState
sconcat :: NonEmpty (IdePlugins ideState) -> IdePlugins ideState
$csconcat :: forall ideState.
NonEmpty (IdePlugins ideState) -> IdePlugins ideState
<> :: IdePlugins ideState -> IdePlugins ideState -> IdePlugins ideState
$c<> :: forall ideState.
IdePlugins ideState -> IdePlugins ideState -> IdePlugins ideState
Semigroup)

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

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

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

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

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

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

data PluginDescriptor ideState =
  PluginDescriptor { PluginDescriptor ideState -> PluginId
pluginId           :: !PluginId
                   , PluginDescriptor ideState -> Rules ()
pluginRules        :: !(Rules ())
                   , PluginDescriptor ideState -> [PluginCommand ideState]
pluginCommands     :: ![PluginCommand ideState]
                   , PluginDescriptor ideState -> PluginHandlers ideState
pluginHandlers     :: PluginHandlers ideState
                   , PluginDescriptor ideState -> ConfigDescriptor
pluginConfigDescriptor :: ConfigDescriptor
                   , PluginDescriptor ideState -> PluginNotificationHandlers ideState
pluginNotificationHandlers :: PluginNotificationHandlers ideState
                   , PluginDescriptor ideState -> DynFlagsModifications
pluginModifyDynflags :: DynFlagsModifications
                   , PluginDescriptor ideState
-> Maybe (ParserInfo (IdeCommand ideState))
pluginCli            :: Maybe (ParserInfo (IdeCommand ideState))
                   }

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

-- | Describes the configuration a plugin.
-- A plugin may be configurable in such form:
-- @
-- {
--  "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 {
  -- | Whether or not to generate generic configs.
  ConfigDescriptor -> Bool
configEnableGenericConfig :: Bool,
  -- | 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 :: Properties r -> CustomConfig
mkCustomConfig = Properties r -> CustomConfig
forall (r :: [PropertyKey]). Properties r -> CustomConfig
CustomConfig

defaultConfigDescriptor :: ConfigDescriptor
defaultConfigDescriptor :: ConfigDescriptor
defaultConfigDescriptor = Bool -> Bool -> CustomConfig -> ConfigDescriptor
ConfigDescriptor Bool
True Bool
False (Properties '[] -> CustomConfig
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 m where

  -- | Parse the configuration to check if this plugin is enabled
  pluginEnabled :: SMethod m -> PluginId -> Config -> Bool

  -- | How to combine responses from different plugins
  combineResponses
    :: SMethod m
    -> Config -- ^ IDE Configuration
    -> ClientCapabilities
    -> MessageParams m
    -> NonEmpty (ResponseResult m) -> ResponseResult m

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

instance PluginMethod TextDocumentCodeAction where
  pluginEnabled :: SMethod 'TextDocumentCodeAction -> PluginId -> Config -> Bool
pluginEnabled SMethod 'TextDocumentCodeAction
_ = (PluginConfig -> Bool) -> PluginId -> Config -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcCodeActionsOn
  combineResponses :: SMethod 'TextDocumentCodeAction
-> Config
-> ClientCapabilities
-> MessageParams 'TextDocumentCodeAction
-> NonEmpty (ResponseResult 'TextDocumentCodeAction)
-> ResponseResult 'TextDocumentCodeAction
combineResponses SMethod 'TextDocumentCodeAction
_method Config
_config (ClientCapabilities Maybe WorkspaceClientCapabilities
_ Maybe TextDocumentClientCapabilities
textDocCaps Maybe WindowClientCapabilities
_ Maybe GeneralClientCapabilities
_ Maybe Object
_) (CodeActionParams _ _ _ _ context) NonEmpty (ResponseResult 'TextDocumentCodeAction)
resps =
      ((Command |? CodeAction) -> Command |? CodeAction)
-> List (Command |? CodeAction) -> List (Command |? CodeAction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Command |? CodeAction) -> Command |? CodeAction
compat (List (Command |? CodeAction) -> List (Command |? CodeAction))
-> List (Command |? CodeAction) -> List (Command |? CodeAction)
forall a b. (a -> b) -> a -> b
$ [Command |? CodeAction] -> List (Command |? CodeAction)
forall a. [a] -> List a
List ([Command |? CodeAction] -> List (Command |? CodeAction))
-> [Command |? CodeAction] -> List (Command |? CodeAction)
forall a b. (a -> b) -> a -> b
$ ((Command |? CodeAction) -> Bool)
-> [Command |? CodeAction] -> [Command |? CodeAction]
forall a. (a -> Bool) -> [a] -> [a]
filter (Command |? CodeAction) -> Bool
wasRequested ([Command |? CodeAction] -> [Command |? CodeAction])
-> [Command |? CodeAction] -> [Command |? CodeAction]
forall a b. (a -> b) -> a -> b
$ (\(List [Command |? CodeAction]
x) -> [Command |? CodeAction]
x) (List (Command |? CodeAction) -> [Command |? CodeAction])
-> List (Command |? CodeAction) -> [Command |? CodeAction]
forall a b. (a -> b) -> a -> b
$ NonEmpty (List (Command |? CodeAction))
-> List (Command |? CodeAction)
forall a. Semigroup a => NonEmpty a -> a
sconcat NonEmpty (ResponseResult 'TextDocumentCodeAction)
NonEmpty (List (Command |? CodeAction))
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 CodeActionLiteralSupport
_ <- Maybe TextDocumentClientCapabilities
textDocCaps Maybe TextDocumentClientCapabilities
-> (TextDocumentClientCapabilities
    -> Maybe CodeActionClientCapabilities)
-> Maybe CodeActionClientCapabilities
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TextDocumentClientCapabilities
-> Maybe CodeActionClientCapabilities
_codeAction Maybe CodeActionClientCapabilities
-> (CodeActionClientCapabilities -> Maybe CodeActionLiteralSupport)
-> Maybe CodeActionLiteralSupport
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CodeActionClientCapabilities -> Maybe CodeActionLiteralSupport
_codeActionLiteralSupport
        = Command |? CodeAction
x
        | Bool
otherwise = Command -> Command |? CodeAction
forall a b. a -> a |? b
InL Command
cmd
        where
          cmd :: Command
cmd = PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
"hls" CommandId
"fallbackCodeAction" (CodeAction
action CodeAction -> Getting Text CodeAction Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text CodeAction Text
forall s a. HasTitle s a => Lens' s a
title) ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Value]
cmdParams)
          cmdParams :: [Value]
cmdParams = [FallbackCodeActionParams -> Value
forall a. ToJSON a => a -> Value
toJSON (Maybe WorkspaceEdit -> Maybe Command -> FallbackCodeActionParams
FallbackCodeActionParams (CodeAction
action CodeAction
-> Getting (Maybe WorkspaceEdit) CodeAction (Maybe WorkspaceEdit)
-> Maybe WorkspaceEdit
forall s a. s -> Getting a s a -> a
^. Getting (Maybe WorkspaceEdit) CodeAction (Maybe WorkspaceEdit)
forall s a. HasEdit s a => Lens' s a
edit) (CodeAction
action CodeAction
-> Getting (Maybe Command) CodeAction (Maybe Command)
-> Maybe Command
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Command) CodeAction (Maybe Command)
forall s a. HasCommand s a => Lens' s a
command))]

      wasRequested :: (Command |? CodeAction) -> Bool
      wasRequested :: (Command |? CodeAction) -> Bool
wasRequested (InL Command
_) = Bool
True
      wasRequested (InR CodeAction
ca)
        | Maybe (List CodeActionKind)
Nothing <- CodeActionContext -> Maybe (List CodeActionKind)
_only CodeActionContext
context = Bool
True
        | Just (List [CodeActionKind]
allowed) <- CodeActionContext -> Maybe (List CodeActionKind)
_only CodeActionContext
context
        -- See https://github.com/microsoft/language-server-protocol/issues/970
        -- This is somewhat vague, but due to the hierarchical nature of action kinds, we
        -- should check whether the requested kind is a *prefix* of the action kind.
        -- That means, for example, we will return actions with kinds `quickfix.import` and
        -- `quickfix.somethingElse` if the requested kind is `quickfix`.
        , Just CodeActionKind
caKind <- CodeAction
ca CodeAction
-> Getting (Maybe CodeActionKind) CodeAction (Maybe CodeActionKind)
-> Maybe CodeActionKind
forall s a. s -> Getting a s a -> a
^. Getting (Maybe CodeActionKind) CodeAction (Maybe CodeActionKind)
forall s a. HasKind s a => Lens' s a
kind = (CodeActionKind -> Bool) -> [CodeActionKind] -> Bool
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 PluginMethod TextDocumentCodeLens where
  pluginEnabled :: SMethod 'TextDocumentCodeLens -> PluginId -> Config -> Bool
pluginEnabled SMethod 'TextDocumentCodeLens
_ = (PluginConfig -> Bool) -> PluginId -> Config -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcCodeLensOn
instance PluginMethod TextDocumentRename where
  pluginEnabled :: SMethod 'TextDocumentRename -> PluginId -> Config -> Bool
pluginEnabled SMethod 'TextDocumentRename
_ = (PluginConfig -> Bool) -> PluginId -> Config -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcRenameOn
instance PluginMethod TextDocumentHover where
  pluginEnabled :: SMethod 'TextDocumentHover -> PluginId -> Config -> Bool
pluginEnabled SMethod 'TextDocumentHover
_ = (PluginConfig -> Bool) -> PluginId -> Config -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcHoverOn
  combineResponses :: SMethod 'TextDocumentHover
-> Config
-> ClientCapabilities
-> MessageParams 'TextDocumentHover
-> NonEmpty (ResponseResult 'TextDocumentHover)
-> ResponseResult 'TextDocumentHover
combineResponses SMethod 'TextDocumentHover
_ Config
_ ClientCapabilities
_ MessageParams 'TextDocumentHover
_ ([Maybe Hover] -> [Hover]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Hover] -> [Hover])
-> (NonEmpty (Maybe Hover) -> [Maybe Hover])
-> NonEmpty (Maybe Hover)
-> [Hover]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Maybe Hover) -> [Maybe Hover]
forall a. NonEmpty a -> [a]
toList -> [Hover]
hs) = Maybe Hover
ResponseResult 'TextDocumentHover
h
    where
      r :: Maybe Range
r = [Range] -> Maybe Range
forall a. [a] -> Maybe a
listToMaybe ([Range] -> Maybe Range) -> [Range] -> Maybe Range
forall a b. (a -> b) -> a -> b
$ (Hover -> Maybe Range) -> [Hover] -> [Range]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Hover -> Getting (Maybe Range) Hover (Maybe Range) -> Maybe Range
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Range) Hover (Maybe Range)
forall s a. HasRange s a => Lens' s a
range) [Hover]
hs
      h :: Maybe Hover
h = case (Hover -> HoverContents) -> [Hover] -> HoverContents
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Hover -> Getting HoverContents Hover HoverContents -> HoverContents
forall s a. s -> Getting a s a -> a
^. Getting HoverContents Hover HoverContents
forall s a. HasContents s a => Lens' s a
contents) [Hover]
hs of
            HoverContentsMS (List []) -> Maybe Hover
forall a. Maybe a
Nothing
            HoverContents
hh                        -> Hover -> Maybe Hover
forall a. a -> Maybe a
Just (Hover -> Maybe Hover) -> Hover -> Maybe Hover
forall a b. (a -> b) -> a -> b
$ HoverContents -> Maybe Range -> Hover
Hover HoverContents
hh Maybe Range
r

instance PluginMethod TextDocumentDocumentSymbol where
  pluginEnabled :: SMethod 'TextDocumentDocumentSymbol -> PluginId -> Config -> Bool
pluginEnabled SMethod 'TextDocumentDocumentSymbol
_ = (PluginConfig -> Bool) -> PluginId -> Config -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcSymbolsOn
  combineResponses :: SMethod 'TextDocumentDocumentSymbol
-> Config
-> ClientCapabilities
-> MessageParams 'TextDocumentDocumentSymbol
-> NonEmpty (ResponseResult 'TextDocumentDocumentSymbol)
-> ResponseResult 'TextDocumentDocumentSymbol
combineResponses SMethod 'TextDocumentDocumentSymbol
_ Config
_ (ClientCapabilities Maybe WorkspaceClientCapabilities
_ Maybe TextDocumentClientCapabilities
tdc Maybe WindowClientCapabilities
_ Maybe GeneralClientCapabilities
_ Maybe Object
_) MessageParams 'TextDocumentDocumentSymbol
params NonEmpty (ResponseResult 'TextDocumentDocumentSymbol)
xs = ResponseResult 'TextDocumentDocumentSymbol
List DocumentSymbol |? List SymbolInformation
res
    where
      uri' :: Uri
uri' = MessageParams 'TextDocumentDocumentSymbol
DocumentSymbolParams
params DocumentSymbolParams -> Getting Uri DocumentSymbolParams Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> DocumentSymbolParams -> Const Uri DocumentSymbolParams
forall s a. HasTextDocument s a => Lens' s a
textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> DocumentSymbolParams -> Const Uri DocumentSymbolParams)
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> Getting Uri DocumentSymbolParams Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
uri
      supportsHierarchy :: Bool
supportsHierarchy = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== (Maybe TextDocumentClientCapabilities
tdc Maybe TextDocumentClientCapabilities
-> (TextDocumentClientCapabilities
    -> Maybe DocumentSymbolClientCapabilities)
-> Maybe DocumentSymbolClientCapabilities
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TextDocumentClientCapabilities
-> Maybe DocumentSymbolClientCapabilities
_documentSymbol Maybe DocumentSymbolClientCapabilities
-> (DocumentSymbolClientCapabilities -> Maybe Bool) -> Maybe Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DocumentSymbolClientCapabilities -> Maybe Bool
_hierarchicalDocumentSymbolSupport)
      dsOrSi :: NonEmpty (Either (List DocumentSymbol) (List SymbolInformation))
dsOrSi = ((List DocumentSymbol |? List SymbolInformation)
 -> Either (List DocumentSymbol) (List SymbolInformation))
-> NonEmpty (List DocumentSymbol |? List SymbolInformation)
-> NonEmpty (Either (List DocumentSymbol) (List SymbolInformation))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (List DocumentSymbol |? List SymbolInformation)
-> Either (List DocumentSymbol) (List SymbolInformation)
forall a b. (a |? b) -> Either a b
toEither NonEmpty (ResponseResult 'TextDocumentDocumentSymbol)
NonEmpty (List DocumentSymbol |? List SymbolInformation)
xs
      res :: List DocumentSymbol |? List SymbolInformation
res
        | Bool
supportsHierarchy = List DocumentSymbol
-> List DocumentSymbol |? List SymbolInformation
forall a b. a -> a |? b
InL (List DocumentSymbol
 -> List DocumentSymbol |? List SymbolInformation)
-> List DocumentSymbol
-> List DocumentSymbol |? List SymbolInformation
forall a b. (a -> b) -> a -> b
$ NonEmpty (List DocumentSymbol) -> List DocumentSymbol
forall a. Semigroup a => NonEmpty a -> a
sconcat (NonEmpty (List DocumentSymbol) -> List DocumentSymbol)
-> NonEmpty (List DocumentSymbol) -> List DocumentSymbol
forall a b. (a -> b) -> a -> b
$ (Either (List DocumentSymbol) (List SymbolInformation)
 -> List DocumentSymbol)
-> NonEmpty (Either (List DocumentSymbol) (List SymbolInformation))
-> NonEmpty (List DocumentSymbol)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((List DocumentSymbol -> List DocumentSymbol)
-> (List SymbolInformation -> List DocumentSymbol)
-> Either (List DocumentSymbol) (List SymbolInformation)
-> List DocumentSymbol
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either List DocumentSymbol -> List DocumentSymbol
forall a. a -> a
id ((SymbolInformation -> DocumentSymbol)
-> List SymbolInformation -> List DocumentSymbol
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SymbolInformation -> DocumentSymbol
siToDs)) NonEmpty (Either (List DocumentSymbol) (List SymbolInformation))
dsOrSi
        | Bool
otherwise = List SymbolInformation
-> List DocumentSymbol |? List SymbolInformation
forall a b. b -> a |? b
InR (List SymbolInformation
 -> List DocumentSymbol |? List SymbolInformation)
-> List SymbolInformation
-> List DocumentSymbol |? List SymbolInformation
forall a b. (a -> b) -> a -> b
$ NonEmpty (List SymbolInformation) -> List SymbolInformation
forall a. Semigroup a => NonEmpty a -> a
sconcat (NonEmpty (List SymbolInformation) -> List SymbolInformation)
-> NonEmpty (List SymbolInformation) -> List SymbolInformation
forall a b. (a -> b) -> a -> b
$ (Either (List DocumentSymbol) (List SymbolInformation)
 -> List SymbolInformation)
-> NonEmpty (Either (List DocumentSymbol) (List SymbolInformation))
-> NonEmpty (List SymbolInformation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((List DocumentSymbol -> List SymbolInformation)
-> (List SymbolInformation -> List SymbolInformation)
-> Either (List DocumentSymbol) (List SymbolInformation)
-> List SymbolInformation
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([SymbolInformation] -> List SymbolInformation
forall a. [a] -> List a
List ([SymbolInformation] -> List SymbolInformation)
-> (List DocumentSymbol -> [SymbolInformation])
-> List DocumentSymbol
-> List SymbolInformation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DocumentSymbol -> [SymbolInformation])
-> List DocumentSymbol -> [SymbolInformation]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DocumentSymbol -> [SymbolInformation]
dsToSi) List SymbolInformation -> List SymbolInformation
forall a. a -> a
id) NonEmpty (Either (List DocumentSymbol) (List SymbolInformation))
dsOrSi
      siToDs :: SymbolInformation -> DocumentSymbol
siToDs (SymbolInformation Text
name SymbolKind
kind Maybe (List SymbolTag)
_tags Maybe Bool
dep (Location Uri
_uri Range
range) Maybe Text
cont)
        = Text
-> Maybe Text
-> SymbolKind
-> Maybe (List SymbolTag)
-> Maybe Bool
-> Range
-> Range
-> Maybe (List DocumentSymbol)
-> DocumentSymbol
DocumentSymbol Text
name Maybe Text
cont SymbolKind
kind Maybe (List SymbolTag)
forall a. Maybe a
Nothing Maybe Bool
dep Range
range Range
range Maybe (List DocumentSymbol)
forall a. Maybe a
Nothing
      dsToSi :: DocumentSymbol -> [SymbolInformation]
dsToSi = Maybe Text -> DocumentSymbol -> [SymbolInformation]
go Maybe Text
forall a. Maybe a
Nothing
      go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation]
      go :: Maybe Text -> DocumentSymbol -> [SymbolInformation]
go Maybe Text
parent DocumentSymbol
ds =
        let children' :: [SymbolInformation]
            children' :: [SymbolInformation]
children' = (DocumentSymbol -> [SymbolInformation])
-> List DocumentSymbol -> [SymbolInformation]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe Text -> DocumentSymbol -> [SymbolInformation]
go (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name')) (List DocumentSymbol
-> Maybe (List DocumentSymbol) -> List DocumentSymbol
forall a. a -> Maybe a -> a
fromMaybe List DocumentSymbol
forall a. Monoid a => a
mempty (DocumentSymbol
ds DocumentSymbol
-> Getting
     (Maybe (List DocumentSymbol))
     DocumentSymbol
     (Maybe (List DocumentSymbol))
-> Maybe (List DocumentSymbol)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (List DocumentSymbol))
  DocumentSymbol
  (Maybe (List DocumentSymbol))
forall s a. HasChildren s a => Lens' s a
children))
            loc :: Location
loc = Uri -> Range -> Location
Location Uri
uri' (DocumentSymbol
ds DocumentSymbol -> Getting Range DocumentSymbol Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range DocumentSymbol Range
forall s a. HasRange s a => Lens' s a
range)
            name' :: Text
name' = DocumentSymbol
ds DocumentSymbol -> Getting Text DocumentSymbol Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text DocumentSymbol Text
forall s a. HasName s a => Lens' s a
name
            si :: SymbolInformation
si = Text
-> SymbolKind
-> Maybe (List SymbolTag)
-> Maybe Bool
-> Location
-> Maybe Text
-> SymbolInformation
SymbolInformation Text
name' (DocumentSymbol
ds DocumentSymbol
-> Getting SymbolKind DocumentSymbol SymbolKind -> SymbolKind
forall s a. s -> Getting a s a -> a
^. Getting SymbolKind DocumentSymbol SymbolKind
forall s a. HasKind s a => Lens' s a
kind) Maybe (List SymbolTag)
forall a. Maybe a
Nothing (DocumentSymbol
ds DocumentSymbol
-> Getting (Maybe Bool) DocumentSymbol (Maybe Bool) -> Maybe Bool
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Bool) DocumentSymbol (Maybe Bool)
forall s a. HasDeprecated s a => Lens' s a
deprecated) Location
loc Maybe Text
parent
        in [SymbolInformation
si] [SymbolInformation] -> [SymbolInformation] -> [SymbolInformation]
forall a. Semigroup a => a -> a -> a
<> [SymbolInformation]
children'

instance PluginMethod TextDocumentCompletion where
  pluginEnabled :: SMethod 'TextDocumentCompletion -> PluginId -> Config -> Bool
pluginEnabled SMethod 'TextDocumentCompletion
_ = (PluginConfig -> Bool) -> PluginId -> Config -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcCompletionOn
  combineResponses :: SMethod 'TextDocumentCompletion
-> Config
-> ClientCapabilities
-> MessageParams 'TextDocumentCompletion
-> NonEmpty (ResponseResult 'TextDocumentCompletion)
-> ResponseResult 'TextDocumentCompletion
combineResponses SMethod 'TextDocumentCompletion
_ Config
conf ClientCapabilities
_ MessageParams 'TextDocumentCompletion
_ (NonEmpty (ResponseResult 'TextDocumentCompletion)
-> [List CompletionItem |? CompletionList]
forall a. NonEmpty a -> [a]
toList -> [List CompletionItem |? CompletionList]
xs) = (Int, List CompletionItem |? CompletionList)
-> List CompletionItem |? CompletionList
forall a b. (a, b) -> b
snd ((Int, List CompletionItem |? CompletionList)
 -> List CompletionItem |? CompletionList)
-> (Int, List CompletionItem |? CompletionList)
-> List CompletionItem |? CompletionList
forall a b. (a -> b) -> a -> b
$ Int
-> (List CompletionItem |? CompletionList)
-> (Int, List CompletionItem |? CompletionList)
consumeCompletionResponse Int
limit ((List CompletionItem |? CompletionList)
 -> (Int, List CompletionItem |? CompletionList))
-> (List CompletionItem |? CompletionList)
-> (Int, List CompletionItem |? CompletionList)
forall a b. (a -> b) -> a -> b
$ [List CompletionItem |? CompletionList]
-> List CompletionItem |? CompletionList
combine [List CompletionItem |? CompletionList]
xs
      where
        limit :: Int
limit = Config -> Int
maxCompletions Config
conf
        combine :: [List CompletionItem |? CompletionList] -> (List CompletionItem |? CompletionList)
        combine :: [List CompletionItem |? CompletionList]
-> List CompletionItem |? CompletionList
combine [List CompletionItem |? CompletionList]
cs = Bool
-> DList CompletionItem
-> [List CompletionItem |? CompletionList]
-> List CompletionItem |? CompletionList
forall a.
Bool
-> DList CompletionItem
-> [List CompletionItem |? CompletionList]
-> a |? CompletionList
go Bool
True DList CompletionItem
forall a. Monoid a => a
mempty [List CompletionItem |? CompletionList]
cs

        go :: Bool
-> DList CompletionItem
-> [List CompletionItem |? CompletionList]
-> a |? CompletionList
go !Bool
comp DList CompletionItem
acc [] =
          CompletionList -> a |? CompletionList
forall a b. b -> a |? b
InR (Bool -> List CompletionItem -> CompletionList
CompletionList Bool
comp ([CompletionItem] -> List CompletionItem
forall a. [a] -> List a
List ([CompletionItem] -> List CompletionItem)
-> [CompletionItem] -> List CompletionItem
forall a b. (a -> b) -> a -> b
$ DList CompletionItem -> [CompletionItem]
forall a. DList a -> [a]
DList.toList DList CompletionItem
acc))
        go Bool
comp DList CompletionItem
acc (InL (List [CompletionItem]
ls) : [List CompletionItem |? CompletionList]
rest) =
          Bool
-> DList CompletionItem
-> [List CompletionItem |? CompletionList]
-> a |? CompletionList
go Bool
comp (DList CompletionItem
acc DList CompletionItem
-> DList CompletionItem -> DList CompletionItem
forall a. Semigroup a => a -> a -> a
<> [CompletionItem] -> DList CompletionItem
forall a. [a] -> DList a
DList.fromList [CompletionItem]
ls) [List CompletionItem |? CompletionList]
rest
        go Bool
comp DList CompletionItem
acc (InR (CompletionList Bool
comp' (List [CompletionItem]
ls)) : [List CompletionItem |? CompletionList]
rest) =
          Bool
-> DList CompletionItem
-> [List CompletionItem |? CompletionList]
-> a |? CompletionList
go (Bool
comp Bool -> Bool -> Bool
&& Bool
comp') (DList CompletionItem
acc DList CompletionItem
-> DList CompletionItem -> DList CompletionItem
forall a. Semigroup a => a -> a -> a
<> [CompletionItem] -> DList CompletionItem
forall a. [a] -> DList a
DList.fromList [CompletionItem]
ls) [List CompletionItem |? CompletionList]
rest

        -- boolean disambiguators
        isCompleteResponse, isIncompleteResponse :: Bool
        isIncompleteResponse :: Bool
isIncompleteResponse = Bool
True
        isCompleteResponse :: Bool
isCompleteResponse = Bool
False

        consumeCompletionResponse :: Int
-> (List CompletionItem |? CompletionList)
-> (Int, List CompletionItem |? CompletionList)
consumeCompletionResponse Int
limit it :: List CompletionItem |? CompletionList
it@(InR (CompletionList Bool
_ (List [CompletionItem]
xx))) =
          case Int -> [CompletionItem] -> ([CompletionItem], [CompletionItem])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
limit [CompletionItem]
xx of
            -- consumed all the items, return the result as is
            ([CompletionItem]
_, []) -> (Int
limit Int -> Int -> Int
forall a. Num a => a -> a -> a
- [CompletionItem] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CompletionItem]
xx, List CompletionItem |? CompletionList
it)
            -- need to crop the response, set the 'isIncomplete' flag
            ([CompletionItem]
xx', [CompletionItem]
_) -> (Int
0, CompletionList -> List CompletionItem |? CompletionList
forall a b. b -> a |? b
InR (Bool -> List CompletionItem -> CompletionList
CompletionList Bool
isIncompleteResponse ([CompletionItem] -> List CompletionItem
forall a. [a] -> List a
List [CompletionItem]
xx')))
        consumeCompletionResponse Int
n (InL (List [CompletionItem]
xx)) =
          Int
-> (List CompletionItem |? CompletionList)
-> (Int, List CompletionItem |? CompletionList)
consumeCompletionResponse Int
n (CompletionList -> List CompletionItem |? CompletionList
forall a b. b -> a |? b
InR (Bool -> List CompletionItem -> CompletionList
CompletionList Bool
isCompleteResponse ([CompletionItem] -> List CompletionItem
forall a. [a] -> List a
List [CompletionItem]
xx)))

instance PluginMethod TextDocumentFormatting where
  pluginEnabled :: SMethod 'TextDocumentFormatting -> PluginId -> Config -> Bool
pluginEnabled SMethod 'TextDocumentFormatting
_ PluginId
pid Config
conf = (Text -> PluginId
PluginId (Text -> PluginId) -> Text -> PluginId
forall a b. (a -> b) -> a -> b
$ Config -> Text
formattingProvider Config
conf) PluginId -> PluginId -> Bool
forall a. Eq a => a -> a -> Bool
== PluginId
pid
  combineResponses :: SMethod 'TextDocumentFormatting
-> Config
-> ClientCapabilities
-> MessageParams 'TextDocumentFormatting
-> NonEmpty (ResponseResult 'TextDocumentFormatting)
-> ResponseResult 'TextDocumentFormatting
combineResponses SMethod 'TextDocumentFormatting
_ Config
_ ClientCapabilities
_ MessageParams 'TextDocumentFormatting
_ (ResponseResult 'TextDocumentFormatting
x :| [ResponseResult 'TextDocumentFormatting]
_) = ResponseResult 'TextDocumentFormatting
x

instance PluginMethod TextDocumentRangeFormatting where
  pluginEnabled :: SMethod 'TextDocumentRangeFormatting -> PluginId -> Config -> Bool
pluginEnabled SMethod 'TextDocumentRangeFormatting
_ PluginId
pid Config
conf = (Text -> PluginId
PluginId (Text -> PluginId) -> Text -> PluginId
forall a b. (a -> b) -> a -> b
$ Config -> Text
formattingProvider Config
conf) PluginId -> PluginId -> Bool
forall a. Eq a => a -> a -> Bool
== PluginId
pid
  combineResponses :: SMethod 'TextDocumentRangeFormatting
-> Config
-> ClientCapabilities
-> MessageParams 'TextDocumentRangeFormatting
-> NonEmpty (ResponseResult 'TextDocumentRangeFormatting)
-> ResponseResult 'TextDocumentRangeFormatting
combineResponses SMethod 'TextDocumentRangeFormatting
_ Config
_ ClientCapabilities
_ MessageParams 'TextDocumentRangeFormatting
_ (ResponseResult 'TextDocumentRangeFormatting
x :| [ResponseResult 'TextDocumentRangeFormatting]
_) = ResponseResult 'TextDocumentRangeFormatting
x

instance PluginMethod TextDocumentPrepareCallHierarchy where
  pluginEnabled :: SMethod 'TextDocumentPrepareCallHierarchy
-> PluginId -> Config -> Bool
pluginEnabled SMethod 'TextDocumentPrepareCallHierarchy
_ = (PluginConfig -> Bool) -> PluginId -> Config -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcCallHierarchyOn

instance PluginMethod TextDocumentSelectionRange where
  pluginEnabled :: SMethod 'TextDocumentSelectionRange -> PluginId -> Config -> Bool
pluginEnabled SMethod 'TextDocumentSelectionRange
_ = (PluginConfig -> Bool) -> PluginId -> Config -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcSelectionRangeOn
  combineResponses :: SMethod 'TextDocumentSelectionRange
-> Config
-> ClientCapabilities
-> MessageParams 'TextDocumentSelectionRange
-> NonEmpty (ResponseResult 'TextDocumentSelectionRange)
-> ResponseResult 'TextDocumentSelectionRange
combineResponses SMethod 'TextDocumentSelectionRange
_ Config
_ ClientCapabilities
_ MessageParams 'TextDocumentSelectionRange
_ (ResponseResult 'TextDocumentSelectionRange
x :| [ResponseResult 'TextDocumentSelectionRange]
_) = ResponseResult 'TextDocumentSelectionRange
x

instance PluginMethod CallHierarchyIncomingCalls where
  pluginEnabled :: SMethod 'CallHierarchyIncomingCalls -> PluginId -> Config -> Bool
pluginEnabled SMethod 'CallHierarchyIncomingCalls
_ = (PluginConfig -> Bool) -> PluginId -> Config -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcCallHierarchyOn

instance PluginMethod CallHierarchyOutgoingCalls where
  pluginEnabled :: SMethod 'CallHierarchyOutgoingCalls -> PluginId -> Config -> Bool
pluginEnabled SMethod 'CallHierarchyOutgoingCalls
_ = (PluginConfig -> Bool) -> PluginId -> Config -> Bool
pluginEnabledConfig PluginConfig -> Bool
plcCallHierarchyOn

instance PluginMethod CustomMethod where
  pluginEnabled :: SMethod 'CustomMethod -> PluginId -> Config -> Bool
pluginEnabled SMethod 'CustomMethod
_ PluginId
_ Config
_ = Bool
True
  combineResponses :: SMethod 'CustomMethod
-> Config
-> ClientCapabilities
-> MessageParams 'CustomMethod
-> NonEmpty (ResponseResult 'CustomMethod)
-> ResponseResult 'CustomMethod
combineResponses SMethod 'CustomMethod
_ Config
_ ClientCapabilities
_ MessageParams 'CustomMethod
_ (ResponseResult 'CustomMethod
x :| [ResponseResult 'CustomMethod]
_) = ResponseResult 'CustomMethod
x

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

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

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

-- | Combine handlers for the
newtype PluginHandler a (m :: Method FromClient Request)
  = PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))

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

newtype PluginHandlers a             = PluginHandlers             (DMap IdeMethod       (PluginHandler a))
newtype PluginNotificationHandlers a = PluginNotificationHandlers (DMap IdeNotification (PluginNotificationHandler a))
instance Semigroup (PluginHandlers a) where
  (PluginHandlers DMap IdeMethod (PluginHandler a)
a) <> :: PluginHandlers a -> PluginHandlers a -> PluginHandlers a
<> (PluginHandlers DMap IdeMethod (PluginHandler a)
b) = DMap IdeMethod (PluginHandler a) -> PluginHandlers a
forall a. DMap IdeMethod (PluginHandler a) -> PluginHandlers a
PluginHandlers (DMap IdeMethod (PluginHandler a) -> PluginHandlers a)
-> DMap IdeMethod (PluginHandler a) -> PluginHandlers a
forall a b. (a -> b) -> a -> b
$ (forall (v :: Method 'FromClient 'Request).
 IdeMethod v
 -> PluginHandler a v -> PluginHandler a v -> PluginHandler a v)
-> DMap IdeMethod (PluginHandler a)
-> DMap IdeMethod (PluginHandler a)
-> DMap IdeMethod (PluginHandler a)
forall k1 (k2 :: k1 -> *) (f :: k1 -> *).
GCompare k2 =>
(forall (v :: k1). k2 v -> f v -> f v -> f v)
-> DMap k2 f -> DMap k2 f -> DMap k2 f
DMap.unionWithKey forall (v :: Method 'FromClient 'Request).
IdeMethod v
-> PluginHandler a v -> PluginHandler a v -> PluginHandler a v
forall (m :: Method 'FromClient 'Request)
       (m :: Method 'FromClient 'Request)
       (m :: Method 'FromClient 'Request) p a.
(ResponseResult m ~ ResponseResult m,
 ResponseResult m ~ ResponseResult 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 ResponseError (ResponseResult m)))
f) (PluginHandler PluginId
-> a
-> MessageParams m
-> LspM Config (NonEmpty (Either ResponseError (ResponseResult m)))
g) = (PluginId
 -> a
 -> MessageParams m
 -> LspM
      Config (NonEmpty (Either ResponseError (ResponseResult m))))
-> PluginHandler a m
forall a (m :: Method 'FromClient 'Request).
(PluginId
 -> a
 -> MessageParams m
 -> LspM
      Config (NonEmpty (Either ResponseError (ResponseResult m))))
-> PluginHandler a m
PluginHandler ((PluginId
  -> a
  -> MessageParams m
  -> LspM
       Config (NonEmpty (Either ResponseError (ResponseResult m))))
 -> PluginHandler a m)
-> (PluginId
    -> a
    -> MessageParams m
    -> LspM
         Config (NonEmpty (Either ResponseError (ResponseResult m))))
-> PluginHandler a m
forall a b. (a -> b) -> a -> b
$ \PluginId
pid a
ide MessageParams m
params ->
        NonEmpty (Either ResponseError (ResponseResult m))
-> NonEmpty (Either ResponseError (ResponseResult m))
-> NonEmpty (Either ResponseError (ResponseResult m))
forall a. Semigroup a => a -> a -> a
(<>) (NonEmpty (Either ResponseError (ResponseResult m))
 -> NonEmpty (Either ResponseError (ResponseResult m))
 -> NonEmpty (Either ResponseError (ResponseResult m)))
-> LspM Config (NonEmpty (Either ResponseError (ResponseResult m)))
-> LspT
     Config
     IO
     (NonEmpty (Either ResponseError (ResponseResult m))
      -> NonEmpty (Either ResponseError (ResponseResult m)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PluginId
-> a
-> MessageParams m
-> LspM Config (NonEmpty (Either ResponseError (ResponseResult m)))
f PluginId
pid a
ide MessageParams m
MessageParams m
params LspT
  Config
  IO
  (NonEmpty (Either ResponseError (ResponseResult m))
   -> NonEmpty (Either ResponseError (ResponseResult m)))
-> LspM Config (NonEmpty (Either ResponseError (ResponseResult m)))
-> LspM Config (NonEmpty (Either ResponseError (ResponseResult m)))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PluginId
-> a
-> MessageParams m
-> LspM Config (NonEmpty (Either ResponseError (ResponseResult m)))
g PluginId
pid a
ide MessageParams m
MessageParams m
params

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

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

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

type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config (Either ResponseError (ResponseResult m))

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

-- | Make a handler for plugins with no extra data
mkPluginHandler
  :: PluginMethod m
  => SClientMethod m
  -> PluginMethodHandler ideState m
  -> PluginHandlers ideState
mkPluginHandler :: SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SClientMethod m
m PluginMethodHandler ideState m
f = DMap IdeMethod (PluginHandler ideState) -> PluginHandlers ideState
forall a. DMap IdeMethod (PluginHandler a) -> PluginHandlers a
PluginHandlers (DMap IdeMethod (PluginHandler ideState)
 -> PluginHandlers ideState)
-> DMap IdeMethod (PluginHandler ideState)
-> PluginHandlers ideState
forall a b. (a -> b) -> a -> b
$ IdeMethod m
-> PluginHandler ideState m
-> DMap IdeMethod (PluginHandler ideState)
forall k1 (k2 :: k1 -> *) (v :: k1) (f :: k1 -> *).
k2 v -> f v -> DMap k2 f
DMap.singleton (SClientMethod m -> IdeMethod m
forall (m :: Method 'FromClient 'Request).
PluginMethod m =>
SMethod m -> IdeMethod m
IdeMethod SClientMethod m
m) ((PluginId
 -> ideState
 -> MessageParams m
 -> LspM
      Config (NonEmpty (Either ResponseError (ResponseResult m))))
-> PluginHandler ideState m
forall a (m :: Method 'FromClient 'Request).
(PluginId
 -> a
 -> MessageParams m
 -> LspM
      Config (NonEmpty (Either ResponseError (ResponseResult m))))
-> PluginHandler a m
PluginHandler PluginId
-> ideState
-> MessageParams m
-> LspM Config (NonEmpty (Either ResponseError (ResponseResult m)))
f')
  where
    f' :: PluginId
-> ideState
-> MessageParams m
-> LspM Config (NonEmpty (Either ResponseError (ResponseResult m)))
f' PluginId
pid ideState
ide MessageParams m
params = Either ResponseError (ResponseResult m)
-> NonEmpty (Either ResponseError (ResponseResult m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (ResponseResult m)
 -> NonEmpty (Either ResponseError (ResponseResult m)))
-> LspT Config IO (Either ResponseError (ResponseResult m))
-> LspM Config (NonEmpty (Either ResponseError (ResponseResult m)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PluginMethodHandler ideState m
f ideState
ide PluginId
pid MessageParams m
params

-- | Make a handler for plugins with no extra data
mkPluginNotificationHandler
  :: HasTracing (MessageParams m)
  => SClientMethod (m :: Method FromClient Notification)
  -> PluginNotificationMethodHandler ideState m
  -> PluginNotificationHandlers ideState
mkPluginNotificationHandler :: SClientMethod m
-> PluginNotificationMethodHandler ideState m
-> PluginNotificationHandlers ideState
mkPluginNotificationHandler SClientMethod m
m PluginNotificationMethodHandler ideState m
f
    = DMap IdeNotification (PluginNotificationHandler ideState)
-> PluginNotificationHandlers ideState
forall a.
DMap IdeNotification (PluginNotificationHandler a)
-> PluginNotificationHandlers a
PluginNotificationHandlers (DMap IdeNotification (PluginNotificationHandler ideState)
 -> PluginNotificationHandlers ideState)
-> DMap IdeNotification (PluginNotificationHandler ideState)
-> PluginNotificationHandlers ideState
forall a b. (a -> b) -> a -> b
$ IdeNotification m
-> PluginNotificationHandler ideState m
-> DMap IdeNotification (PluginNotificationHandler ideState)
forall k1 (k2 :: k1 -> *) (v :: k1) (f :: k1 -> *).
k2 v -> f v -> DMap k2 f
DMap.singleton (SClientMethod m -> IdeNotification m
forall (m :: Method 'FromClient 'Notification).
HasTracing (MessageParams m) =>
SMethod m -> IdeNotification m
IdeNotification SClientMethod m
m) ((PluginId -> ideState -> VFS -> MessageParams m -> LspM Config ())
-> PluginNotificationHandler ideState m
forall a (m :: Method 'FromClient '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

defaultPluginDescriptor :: PluginId -> PluginDescriptor ideState
defaultPluginDescriptor :: PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId =
  PluginId
-> Rules ()
-> [PluginCommand ideState]
-> PluginHandlers ideState
-> ConfigDescriptor
-> PluginNotificationHandlers ideState
-> DynFlagsModifications
-> Maybe (ParserInfo (IdeCommand ideState))
-> PluginDescriptor ideState
forall ideState.
PluginId
-> Rules ()
-> [PluginCommand ideState]
-> PluginHandlers ideState
-> ConfigDescriptor
-> PluginNotificationHandlers ideState
-> DynFlagsModifications
-> Maybe (ParserInfo (IdeCommand ideState))
-> PluginDescriptor ideState
PluginDescriptor
    PluginId
plId
    Rules ()
forall a. Monoid a => a
mempty
    [PluginCommand ideState]
forall a. Monoid a => a
mempty
    PluginHandlers ideState
forall a. Monoid a => a
mempty
    ConfigDescriptor
defaultConfigDescriptor
    PluginNotificationHandlers ideState
forall a. Monoid a => a
mempty
    DynFlagsModifications
forall a. Monoid a => a
mempty
    Maybe (ParserInfo (IdeCommand ideState))
forall a. Maybe a
Nothing

newtype CommandId = CommandId T.Text
  deriving (Int -> CommandId -> ShowS
[CommandId] -> ShowS
CommandId -> String
(Int -> CommandId -> ShowS)
-> (CommandId -> String)
-> ([CommandId] -> ShowS)
-> Show CommandId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
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]
(Int -> ReadS CommandId)
-> ReadS [CommandId]
-> ReadPrec CommandId
-> ReadPrec [CommandId]
-> Read 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
(CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> Bool) -> Eq CommandId
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
Eq CommandId
-> (CommandId -> CommandId -> Ordering)
-> (CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> CommandId)
-> (CommandId -> CommandId -> CommandId)
-> Ord CommandId
CommandId -> CommandId -> Bool
CommandId -> CommandId -> Ordering
CommandId -> CommandId -> CommandId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
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
$cp1Ord :: Eq CommandId
Ord)
instance IsString CommandId where
  fromString :: String -> CommandId
fromString = Text -> CommandId
CommandId (Text -> CommandId) -> (String -> Text) -> String -> CommandId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

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

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

type CommandFunction ideState a
  = ideState
  -> a
  -> LspM Config (Either ResponseError Value)

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

newtype PluginId = PluginId T.Text
  deriving (Int -> PluginId -> ShowS
[PluginId] -> ShowS
PluginId -> String
(Int -> PluginId -> ShowS)
-> (PluginId -> String) -> ([PluginId] -> ShowS) -> Show PluginId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
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]
(Int -> ReadS PluginId)
-> ReadS [PluginId]
-> ReadPrec PluginId
-> ReadPrec [PluginId]
-> Read 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
(PluginId -> PluginId -> Bool)
-> (PluginId -> PluginId -> Bool) -> Eq PluginId
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
Eq PluginId
-> (PluginId -> PluginId -> Ordering)
-> (PluginId -> PluginId -> Bool)
-> (PluginId -> PluginId -> Bool)
-> (PluginId -> PluginId -> Bool)
-> (PluginId -> PluginId -> Bool)
-> (PluginId -> PluginId -> PluginId)
-> (PluginId -> PluginId -> PluginId)
-> Ord PluginId
PluginId -> PluginId -> Bool
PluginId -> PluginId -> Ordering
PluginId -> PluginId -> PluginId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
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
$cp1Ord :: Eq PluginId
Ord)

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

configForPlugin :: Config -> PluginId -> PluginConfig
configForPlugin :: Config -> PluginId -> PluginConfig
configForPlugin Config
config (PluginId Text
plugin)
    = PluginConfig -> Text -> Map Text PluginConfig -> PluginConfig
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault PluginConfig
forall a. Default a => a
Data.Default.def Text
plugin (Config -> Map Text PluginConfig
plugins Config
config)

-- | Checks that a given plugin is both enabled and the specific feature is
-- enabled
pluginEnabledConfig :: (PluginConfig -> Bool) -> PluginId -> Config -> Bool
pluginEnabledConfig :: (PluginConfig -> Bool) -> PluginId -> Config -> Bool
pluginEnabledConfig PluginConfig -> Bool
f PluginId
pid Config
config = PluginConfig -> Bool
plcGlobalOn PluginConfig
pluginConfig Bool -> Bool -> Bool
&& PluginConfig -> Bool
f PluginConfig
pluginConfig
  where
    pluginConfig :: PluginConfig
pluginConfig = Config -> PluginId -> PluginConfig
configForPlugin Config
config PluginId
pid

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

-- | 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 =
  ( J.HasOptions (MessageParams m) FormattingOptions
  , J.HasTextDocument (MessageParams m) TextDocumentIdentifier
  , ResponseResult m ~ List TextEdit
  )

type FormattingHandler a
  =  a
  -> FormattingType
  -> T.Text
  -> NormalizedFilePath
  -> FormattingOptions
  -> LspM Config (Either ResponseError (List TextEdit))

mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a
mkFormattingHandlers :: FormattingHandler a -> PluginHandlers a
mkFormattingHandlers FormattingHandler a
f = SMethod 'TextDocumentFormatting
-> PluginMethodHandler a 'TextDocumentFormatting
-> PluginHandlers a
forall (m :: Method 'FromClient 'Request) ideState.
PluginMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'TextDocumentFormatting
STextDocumentFormatting (SMethod 'TextDocumentFormatting
-> PluginMethodHandler a 'TextDocumentFormatting
forall (f :: From) (m :: Method f 'Request).
FormattingMethod m =>
SMethod m -> PluginMethodHandler a m
provider SMethod 'TextDocumentFormatting
STextDocumentFormatting)
                      PluginHandlers a -> PluginHandlers a -> PluginHandlers a
forall a. Semigroup a => a -> a -> a
<> SMethod 'TextDocumentRangeFormatting
-> PluginMethodHandler a 'TextDocumentRangeFormatting
-> PluginHandlers a
forall (m :: Method 'FromClient 'Request) ideState.
PluginMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler SMethod 'TextDocumentRangeFormatting
STextDocumentRangeFormatting (SMethod 'TextDocumentRangeFormatting
-> PluginMethodHandler a 'TextDocumentRangeFormatting
forall (f :: From) (m :: Method f 'Request).
FormattingMethod m =>
SMethod m -> PluginMethodHandler a m
provider SMethod 'TextDocumentRangeFormatting
STextDocumentRangeFormatting)
  where
    provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler a m
    provider :: SMethod m -> PluginMethodHandler a m
provider SMethod m
m a
ide PluginId
_pid MessageParams m
params
      | Just NormalizedFilePath
nfp <- NormalizedUri -> Maybe NormalizedFilePath
uriToNormalizedFilePath (NormalizedUri -> Maybe NormalizedFilePath)
-> NormalizedUri -> Maybe NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
uri = do
        Maybe VirtualFile
mf <- NormalizedUri -> LspT Config IO (Maybe VirtualFile)
forall config (m :: * -> *).
MonadLsp config m =>
NormalizedUri -> m (Maybe VirtualFile)
getVirtualFile (NormalizedUri -> LspT Config IO (Maybe VirtualFile))
-> NormalizedUri -> LspT Config IO (Maybe VirtualFile)
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
STextDocumentFormatting -> FormattingType
FormatText
                  SMethod m
STextDocumentRangeFormatting -> Range -> FormattingType
FormatRange (MessageParams m
DocumentRangeFormattingParams
params DocumentRangeFormattingParams
-> Getting Range DocumentRangeFormattingParams Range -> Range
forall s a. s -> Getting a s a -> a
^. Getting Range DocumentRangeFormattingParams Range
forall s a. HasRange s a => Lens' s a
J.range)
                  SMethod m
_ -> String -> FormattingType
forall a. HasCallStack => String -> a
error String
"mkFormattingHandlers: impossible"
            FormattingHandler a
f a
ide FormattingType
typ (VirtualFile -> Text
virtualFileText VirtualFile
vf) NormalizedFilePath
nfp FormattingOptions
opts
          Maybe VirtualFile
Nothing -> Either ResponseError (List TextEdit)
-> LspT Config IO (Either ResponseError (List TextEdit))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (List TextEdit)
 -> LspT Config IO (Either ResponseError (List TextEdit)))
-> Either ResponseError (List TextEdit)
-> LspT Config IO (Either ResponseError (List TextEdit))
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError (List TextEdit)
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError (List TextEdit))
-> ResponseError -> Either ResponseError (List TextEdit)
forall a b. (a -> b) -> a -> b
$ Text -> ResponseError
responseError (Text -> ResponseError) -> Text -> ResponseError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Formatter plugin: could not get file contents for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Uri -> String
forall a. Show a => a -> String
show Uri
uri

      | Bool
otherwise = Either ResponseError (List TextEdit)
-> LspT Config IO (Either ResponseError (List TextEdit))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ResponseError (List TextEdit)
 -> LspT Config IO (Either ResponseError (List TextEdit)))
-> Either ResponseError (List TextEdit)
-> LspT Config IO (Either ResponseError (List TextEdit))
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError (List TextEdit)
forall a b. a -> Either a b
Left (ResponseError -> Either ResponseError (List TextEdit))
-> ResponseError -> Either ResponseError (List TextEdit)
forall a b. (a -> b) -> a -> b
$ Text -> ResponseError
responseError (Text -> ResponseError) -> Text -> ResponseError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Formatter plugin: uriToFilePath failed for: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Uri -> String
forall a. Show a => a -> String
show Uri
uri
      where
        uri :: Uri
uri = MessageParams m
params MessageParams m -> Getting Uri (MessageParams m) Uri -> Uri
forall s a. s -> Getting a s a -> a
^. (TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> MessageParams m -> Const Uri (MessageParams m)
forall s a. HasTextDocument s a => Lens' s a
J.textDocument ((TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
 -> MessageParams m -> Const Uri (MessageParams m))
-> ((Uri -> Const Uri Uri)
    -> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier)
-> Getting Uri (MessageParams m) Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> TextDocumentIdentifier -> Const Uri TextDocumentIdentifier
forall s a. HasUri s a => Lens' s a
J.uri
        opts :: FormattingOptions
opts = MessageParams m
params MessageParams m
-> Getting FormattingOptions (MessageParams m) FormattingOptions
-> FormattingOptions
forall s a. s -> Getting a s a -> a
^. Getting FormattingOptions (MessageParams m) FormattingOptions
forall s a. HasOptions s a => Lens' s a
J.options

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

responseError :: T.Text -> ResponseError
responseError :: Text -> ResponseError
responseError Text
txt = ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InvalidParams Text
txt Maybe Value
forall a. Maybe a
Nothing

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

data FallbackCodeActionParams =
  FallbackCodeActionParams
    { FallbackCodeActionParams -> Maybe WorkspaceEdit
fallbackWorkspaceEdit :: Maybe WorkspaceEdit
    , FallbackCodeActionParams -> Maybe Command
fallbackCommand       :: Maybe Command
    }
  deriving ((forall x.
 FallbackCodeActionParams -> Rep FallbackCodeActionParams x)
-> (forall x.
    Rep FallbackCodeActionParams x -> FallbackCodeActionParams)
-> Generic FallbackCodeActionParams
forall x.
Rep FallbackCodeActionParams x -> FallbackCodeActionParams
forall x.
FallbackCodeActionParams -> Rep FallbackCodeActionParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep FallbackCodeActionParams x -> FallbackCodeActionParams
$cfrom :: forall x.
FallbackCodeActionParams -> Rep FallbackCodeActionParams x
Generic, [FallbackCodeActionParams] -> Encoding
[FallbackCodeActionParams] -> Value
FallbackCodeActionParams -> Encoding
FallbackCodeActionParams -> Value
(FallbackCodeActionParams -> Value)
-> (FallbackCodeActionParams -> Encoding)
-> ([FallbackCodeActionParams] -> Value)
-> ([FallbackCodeActionParams] -> Encoding)
-> ToJSON FallbackCodeActionParams
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
(Value -> Parser FallbackCodeActionParams)
-> (Value -> Parser [FallbackCodeActionParams])
-> FromJSON 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) = SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"uri" (Text -> ByteString
encodeUtf8 Text
t)

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

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

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

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

{-# NOINLINE pROCESS_ID #-}
pROCESS_ID :: T.Text
pROCESS_ID :: Text
pROCESS_ID = IO Text -> Text
forall a. IO a -> a
unsafePerformIO IO Text
getPid

mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [Value] -> Command
mkLspCommand :: PluginId -> CommandId -> Text -> Maybe [Value] -> Command
mkLspCommand PluginId
plid CommandId
cn Text
title Maybe [Value]
args' = Text -> Text -> Maybe (List Value) -> Command
Command Text
title Text
cmdId Maybe (List Value)
args
  where
    cmdId :: Text
cmdId = Text -> PluginId -> CommandId -> Text
mkLspCmdId Text
pROCESS_ID PluginId
plid CommandId
cn
    args :: Maybe (List Value)
args = [Value] -> List Value
forall a. [a] -> List a
List ([Value] -> List Value) -> Maybe [Value] -> Maybe (List Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Value]
args'

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

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

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

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

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

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