mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-19 04:37:25 +03:00
Break down ghcide functionality in HLS plugins (#1257)
* Clean up no longer needed handlers * Move some log lines to debug verbosity * Extract type signature code lenses to an HLS plugin This was worth doing to clean up the messy command handlers * Extract the block command handler to an HLS plugin Previously defined together with the type lenses command handler * fix command capability check * Extract completions into an HLS plugin We might want to break them down into multiple HLS plugins later on (local, non local, and module header). * Extract code actions into an HLS plugin * Group ghcide plugins
This commit is contained in:
parent
e06469f2b4
commit
0c9dd30e38
@ -2,14 +2,14 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Plugins where
|
||||
|
||||
import Ide.Types (IdePlugins)
|
||||
import Ide.Types (IdePlugins)
|
||||
import Ide.PluginUtils (pluginDescToIdePlugins)
|
||||
|
||||
-- fixed plugins
|
||||
import Ide.Plugin.Example as Example
|
||||
import Ide.Plugin.Example2 as Example2
|
||||
import Development.IDE (IdeState)
|
||||
import Development.IDE.Plugin.HLS.GhcIde as GhcIde
|
||||
import Development.IDE.Plugin.HLS.GhcIde as GhcIde
|
||||
|
||||
-- haskell-language-server optional plugins
|
||||
|
||||
@ -89,53 +89,53 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
|
||||
then basePlugins ++ examplePlugins
|
||||
else basePlugins
|
||||
basePlugins =
|
||||
[ GhcIde.descriptor "ghcide"
|
||||
GhcIde.descriptors ++
|
||||
#if pragmas
|
||||
, Pragmas.descriptor "pragmas"
|
||||
Pragmas.descriptor "pragmas" :
|
||||
#endif
|
||||
#if floskell
|
||||
, Floskell.descriptor "floskell"
|
||||
Floskell.descriptor "floskell" :
|
||||
#endif
|
||||
#if fourmolu
|
||||
, Fourmolu.descriptor "fourmolu"
|
||||
Fourmolu.descriptor "fourmolu" :
|
||||
#endif
|
||||
#if tactic
|
||||
, Tactic.descriptor "tactic"
|
||||
Tactic.descriptor "tactic" :
|
||||
#endif
|
||||
#if ormolu
|
||||
, Ormolu.descriptor "ormolu"
|
||||
Ormolu.descriptor "ormolu" :
|
||||
#endif
|
||||
#if stylishHaskell
|
||||
, StylishHaskell.descriptor "stylish-haskell"
|
||||
StylishHaskell.descriptor "stylish-haskell" :
|
||||
#endif
|
||||
#if retrie
|
||||
, Retrie.descriptor "retrie"
|
||||
Retrie.descriptor "retrie" :
|
||||
#endif
|
||||
#if AGPL && brittany
|
||||
, Brittany.descriptor "brittany"
|
||||
Brittany.descriptor "brittany" :
|
||||
#endif
|
||||
#if class
|
||||
, Class.descriptor "class"
|
||||
Class.descriptor "class" :
|
||||
#endif
|
||||
#if haddockComments
|
||||
, HaddockComments.descriptor "haddockComments"
|
||||
HaddockComments.descriptor "haddockComments" :
|
||||
#endif
|
||||
#if eval
|
||||
, Eval.descriptor "eval"
|
||||
Eval.descriptor "eval" :
|
||||
#endif
|
||||
#if importLens
|
||||
, ExplicitImports.descriptor "importLens"
|
||||
ExplicitImports.descriptor "importLens" :
|
||||
#endif
|
||||
#if moduleName
|
||||
, ModuleName.descriptor "moduleName"
|
||||
ModuleName.descriptor "moduleName" :
|
||||
#endif
|
||||
#if hlint
|
||||
, Hlint.descriptor "hlint"
|
||||
Hlint.descriptor "hlint" :
|
||||
#endif
|
||||
#if splice
|
||||
, Splice.descriptor "splice"
|
||||
Splice.descriptor "splice" :
|
||||
#endif
|
||||
]
|
||||
[]
|
||||
examplePlugins =
|
||||
[Example.descriptor "eg"
|
||||
,Example2.descriptor "eg2"
|
||||
|
@ -87,7 +87,9 @@ main = do
|
||||
|
||||
dir <- IO.getCurrentDirectory
|
||||
|
||||
let hlsPlugins = pluginDescToIdePlugins [GhcIde.descriptor "ghcide"]
|
||||
let hlsPlugins = pluginDescToIdePlugins $
|
||||
GhcIde.descriptors ++
|
||||
[ Test.blockCommandDescriptor "block-command" | argsTesting]
|
||||
|
||||
pid <- T.pack . show <$> getProcessID
|
||||
let hlsPlugin = asGhcIdePlugin hlsPlugins
|
||||
|
@ -173,6 +173,7 @@ library
|
||||
Development.IDE.Plugin.HLS
|
||||
Development.IDE.Plugin.HLS.GhcIde
|
||||
Development.IDE.Plugin.Test
|
||||
Development.IDE.Plugin.TypeLenses
|
||||
|
||||
-- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses
|
||||
-- the real GHC library and the types are incompatible. Furthermore, when
|
||||
|
@ -4,8 +4,7 @@
|
||||
|
||||
-- | Display information on hover.
|
||||
module Development.IDE.LSP.HoverDefinition
|
||||
( setHandlersHover
|
||||
, setHandlersDefinition
|
||||
( setHandlersDefinition
|
||||
, setHandlersTypeDefinition
|
||||
, setHandlersDocHighlight
|
||||
-- * For haskell-language-server
|
||||
@ -38,13 +37,11 @@ foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover
|
||||
foundHover (mbRange, contents) =
|
||||
Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange
|
||||
|
||||
setHandlersDefinition, setHandlersHover, setHandlersTypeDefinition, setHandlersDocHighlight :: PartialHandlers c
|
||||
setHandlersDefinition, setHandlersTypeDefinition, setHandlersDocHighlight :: PartialHandlers c
|
||||
setHandlersDefinition = PartialHandlers $ \WithMessage{..} x ->
|
||||
return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition}
|
||||
setHandlersTypeDefinition = PartialHandlers $ \WithMessage{..} x ->
|
||||
return x{LSP.typeDefinitionHandler = withResponse RspDefinition $ const gotoTypeDefinition}
|
||||
setHandlersHover = PartialHandlers $ \WithMessage{..} x ->
|
||||
return x{LSP.hoverHandler = withResponse RspHover $ const hover}
|
||||
return x {LSP.typeDefinitionHandler = withResponse RspDefinition $ const gotoTypeDefinition}
|
||||
setHandlersDocHighlight = PartialHandlers $ \WithMessage{..} x ->
|
||||
return x{LSP.documentHighlightHandler = withResponse RspDocumentHighlights $ const documentHighlight}
|
||||
|
||||
|
@ -108,7 +108,7 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
|
||||
let PartialHandlers parts =
|
||||
initializeRequestHandler <>
|
||||
setHandlersIgnore <> -- least important
|
||||
setHandlersDefinition <> setHandlersHover <> setHandlersTypeDefinition <>
|
||||
setHandlersDefinition <> setHandlersTypeDefinition <>
|
||||
setHandlersDocHighlight <>
|
||||
setHandlersOutline <>
|
||||
userHandlers <>
|
||||
|
@ -1,19 +1,10 @@
|
||||
module Development.IDE.Plugin
|
||||
( Plugin(..)
|
||||
, codeActionPlugin
|
||||
, codeActionPluginWithRules
|
||||
, makeLspCommandId
|
||||
) where
|
||||
|
||||
import Data.Default
|
||||
import qualified Data.Text as T
|
||||
import Development.Shake
|
||||
import Development.IDE.LSP.Server
|
||||
import Development.IDE.Core.Rules
|
||||
import Ide.PluginUtils
|
||||
import Language.Haskell.LSP.Types
|
||||
import qualified Language.Haskell.LSP.Core as LSP
|
||||
import Language.Haskell.LSP.Messages
|
||||
|
||||
|
||||
data Plugin c = Plugin
|
||||
@ -29,29 +20,3 @@ instance Semigroup (Plugin c) where
|
||||
|
||||
instance Monoid (Plugin c) where
|
||||
mempty = def
|
||||
|
||||
|
||||
codeActionPlugin :: (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c
|
||||
codeActionPlugin = codeActionPluginWithRules mempty
|
||||
|
||||
codeActionPluginWithRules :: Rules () -> (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c
|
||||
codeActionPluginWithRules rr f = Plugin rr $ PartialHandlers $ \WithMessage{..} x -> return x{
|
||||
LSP.codeActionHandler = withResponse RspCodeAction g
|
||||
}
|
||||
where
|
||||
g lsp state (CodeActionParams a b c _) = fmap List <$> f lsp state a b c
|
||||
|
||||
-- | Prefix to uniquely identify commands sent to the client. This
|
||||
-- has two parts
|
||||
--
|
||||
-- - A representation of the process id to make sure that a client has
|
||||
-- unique commands if it is running multiple servers, since some
|
||||
-- clients have a global command table and get confused otherwise.
|
||||
--
|
||||
-- - A string to identify ghcide, to ease integration into
|
||||
-- haskell-language-server, which routes commands to plugins based
|
||||
-- on that.
|
||||
makeLspCommandId :: T.Text -> IO T.Text
|
||||
makeLspCommandId command = do
|
||||
pid <- getProcessID
|
||||
return $ T.pack (show pid) <> ":ghcide:" <> command
|
||||
|
@ -7,23 +7,13 @@
|
||||
|
||||
-- | Go to the definition of a variable.
|
||||
module Development.IDE.Plugin.CodeAction
|
||||
(
|
||||
plugin
|
||||
|
||||
-- * For haskell-language-server
|
||||
, codeAction
|
||||
, codeLens
|
||||
, rulePackageExports
|
||||
, commandHandler
|
||||
( descriptor
|
||||
|
||||
-- * For testing
|
||||
, blockCommandId
|
||||
, typeSignatureCommandId
|
||||
, matchRegExMultipleImports
|
||||
) where
|
||||
|
||||
import Control.Monad (join, guard)
|
||||
import Development.IDE.Plugin
|
||||
import Development.IDE.GHC.Compat
|
||||
import Development.IDE.Core.Rules
|
||||
import Development.IDE.Core.RuleTypes
|
||||
@ -31,22 +21,19 @@ import Development.IDE.Core.Service
|
||||
import Development.IDE.Core.Shake
|
||||
import Development.IDE.GHC.Error
|
||||
import Development.IDE.GHC.ExactPrint
|
||||
import Development.IDE.LSP.Server
|
||||
import Development.IDE.Plugin.CodeAction.ExactPrint
|
||||
import Development.IDE.Plugin.CodeAction.PositionIndexed
|
||||
import Development.IDE.Plugin.CodeAction.RuleTypes
|
||||
import Development.IDE.Plugin.CodeAction.Rules
|
||||
import Development.IDE.Plugin.TypeLenses (suggestSignature)
|
||||
import Development.IDE.Types.Exports
|
||||
import Development.IDE.Types.Location
|
||||
import Development.IDE.Types.Options
|
||||
import Development.Shake (Rules)
|
||||
import qualified Data.HashMap.Strict as Map
|
||||
import qualified Language.Haskell.LSP.Core as LSP
|
||||
import Language.Haskell.LSP.VFS
|
||||
import Language.Haskell.LSP.Messages
|
||||
import Language.Haskell.LSP.Types
|
||||
import qualified Data.Rope.UTF16 as Rope
|
||||
import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))
|
||||
import Data.Char
|
||||
import Data.Maybe
|
||||
import Data.List.Extra
|
||||
@ -62,33 +49,28 @@ import Control.Applicative ((<|>))
|
||||
import Safe (atMay)
|
||||
import Bag (isEmptyBag)
|
||||
import qualified Data.HashSet as Set
|
||||
import Control.Concurrent.Extra (threadDelay, readVar)
|
||||
import Control.Concurrent.Extra (readVar)
|
||||
import Development.IDE.GHC.Util (printRdrName)
|
||||
import Ide.PluginUtils (subRange)
|
||||
import Ide.Types
|
||||
|
||||
plugin :: Plugin c
|
||||
plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens
|
||||
|
||||
rules :: Rules ()
|
||||
rules = do
|
||||
rulePackageExports
|
||||
|
||||
-- | a command that blocks forever. Used for testing
|
||||
blockCommandId :: T.Text
|
||||
blockCommandId = "ghcide.command.block"
|
||||
|
||||
typeSignatureCommandId :: T.Text
|
||||
typeSignatureCommandId = "typesignature.add"
|
||||
descriptor :: PluginId -> PluginDescriptor IdeState
|
||||
descriptor plId =
|
||||
(defaultPluginDescriptor plId)
|
||||
{ pluginRules = rulePackageExports,
|
||||
pluginCodeActionProvider = Just codeAction
|
||||
}
|
||||
|
||||
-- | Generate code actions.
|
||||
codeAction
|
||||
:: LSP.LspFuncs c
|
||||
-> IdeState
|
||||
-> PluginId
|
||||
-> TextDocumentIdentifier
|
||||
-> Range
|
||||
-> CodeActionContext
|
||||
-> IO (Either ResponseError [CAResult])
|
||||
codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do
|
||||
-> IO (Either ResponseError (List CAResult))
|
||||
codeAction lsp state _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do
|
||||
contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
|
||||
let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
|
||||
mbFile = toNormalizedFilePath' <$> uriToFilePath uri
|
||||
@ -122,58 +104,12 @@ codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diag
|
||||
<> actions
|
||||
<> actions'
|
||||
<> caRemoveInvalidExports parsedModule text diag xs uri
|
||||
pure $ Right actions''
|
||||
pure $ Right $ List actions''
|
||||
|
||||
mkCA :: T.Text -> [Diagnostic] -> WorkspaceEdit -> CAResult
|
||||
mkCA title diags edit =
|
||||
CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List diags) (Just edit) Nothing
|
||||
|
||||
-- | Generate code lenses.
|
||||
codeLens
|
||||
:: LSP.LspFuncs c
|
||||
-> IdeState
|
||||
-> CodeLensParams
|
||||
-> IO (Either ResponseError (List CodeLens))
|
||||
codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
|
||||
commandId <- makeLspCommandId "typesignature.add"
|
||||
fmap (Right . List) $ case uriToFilePath' uri of
|
||||
Just (toNormalizedFilePath' -> filePath) -> do
|
||||
_ <- runAction "codeLens" ideState (use TypeCheck filePath)
|
||||
diag <- getDiagnostics ideState
|
||||
hDiag <- getHiddenDiagnostics ideState
|
||||
pure
|
||||
[ CodeLens _range (Just (Command title commandId (Just $ List [toJSON edit]))) Nothing
|
||||
| (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag
|
||||
, dFile == filePath
|
||||
, (title, tedit) <- suggestSignature False dDiag
|
||||
, let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
|
||||
]
|
||||
Nothing -> pure []
|
||||
|
||||
-- | Execute the "typesignature.add" command.
|
||||
commandHandler
|
||||
:: LSP.LspFuncs c
|
||||
-> IdeState
|
||||
-> ExecuteCommandParams
|
||||
-> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
|
||||
commandHandler lsp _ideState ExecuteCommandParams{..}
|
||||
-- _command is prefixed with a process ID, because certain clients
|
||||
-- have a global command registry, and all commands must be
|
||||
-- unique. And there can be more than one ghcide instance running
|
||||
-- at a time against the same client.
|
||||
| T.isSuffixOf blockCommandId _command
|
||||
= do
|
||||
LSP.sendFunc lsp $ NotCustomServer $
|
||||
NotificationMessage "2.0" (CustomServerMethod "ghcide/blocking/command") Null
|
||||
threadDelay maxBound
|
||||
return (Right Null, Nothing)
|
||||
| T.isSuffixOf typeSignatureCommandId _command
|
||||
, Just (List [edit]) <- _arguments
|
||||
, Success wedit <- fromJSON edit
|
||||
= return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
|
||||
| otherwise
|
||||
= return (Right Null, Nothing)
|
||||
|
||||
suggestExactAction ::
|
||||
ExportsMap ->
|
||||
DynFlags ->
|
||||
@ -783,31 +719,6 @@ suggestFixConstructorImport _ Diagnostic{_range=_range,..}
|
||||
= let fixedImport = typ <> "(" <> constructor <> ")"
|
||||
in [("Fix import of " <> fixedImport, [TextEdit _range fixedImport])]
|
||||
| otherwise = []
|
||||
|
||||
suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
|
||||
suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
|
||||
| _message =~
|
||||
("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text) = let
|
||||
signature = removeInitialForAll
|
||||
$ T.takeWhile (\x -> x/='*' && x/='•')
|
||||
$ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
|
||||
startOfLine = Position (_line _start) startCharacter
|
||||
beforeLine = Range startOfLine startOfLine
|
||||
title = if isQuickFix then "add signature: " <> signature else signature
|
||||
action = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " "
|
||||
in [(title, [action])]
|
||||
where removeInitialForAll :: T.Text -> T.Text
|
||||
removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))
|
||||
| "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))
|
||||
| otherwise = nm <> ty
|
||||
startCharacter
|
||||
| "Polymorphic local binding" `T.isPrefixOf` _message
|
||||
= _character _start
|
||||
| otherwise
|
||||
= 0
|
||||
|
||||
suggestSignature _ _ = []
|
||||
|
||||
-- | Suggests a constraint for a declaration for which a constraint is missing.
|
||||
suggestConstraint :: DynFlags -> ParsedSource -> Diagnostic -> [(T.Text, Rewrite)]
|
||||
suggestConstraint df parsedModule diag@Diagnostic {..}
|
||||
@ -1201,21 +1112,6 @@ matchRegex :: T.Text -> T.Text -> Maybe [T.Text]
|
||||
matchRegex message regex = case message =~~ regex of
|
||||
Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings
|
||||
Nothing -> Nothing
|
||||
|
||||
setHandlersCodeLens :: PartialHandlers c
|
||||
setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{
|
||||
LSP.codeLensHandler =
|
||||
withResponse RspCodeLens codeLens,
|
||||
LSP.executeCommandHandler =
|
||||
withResponseAndRequest
|
||||
RspExecuteCommand
|
||||
ReqApplyWorkspaceEdit
|
||||
commandHandler
|
||||
}
|
||||
|
||||
filterNewlines :: T.Text -> T.Text
|
||||
filterNewlines = T.concat . T.lines
|
||||
|
||||
unifySpaces :: T.Text -> T.Text
|
||||
unifySpaces = T.unwords . T.words
|
||||
|
||||
|
@ -3,12 +3,11 @@
|
||||
#include "ghc-api-version.h"
|
||||
|
||||
module Development.IDE.Plugin.Completions
|
||||
(
|
||||
plugin
|
||||
, getCompletionsLSP
|
||||
( descriptor
|
||||
, ProduceCompletions(..)
|
||||
, LocalCompletions(..)
|
||||
, NonLocalCompletions(..)
|
||||
) where
|
||||
|
||||
import Language.Haskell.LSP.Messages
|
||||
import Language.Haskell.LSP.Types
|
||||
import qualified Language.Haskell.LSP.Core as LSP
|
||||
import qualified Language.Haskell.LSP.VFS as VFS
|
||||
@ -16,8 +15,6 @@ import qualified Language.Haskell.LSP.VFS as VFS
|
||||
import Development.Shake.Classes
|
||||
import Development.Shake
|
||||
import GHC.Generics
|
||||
|
||||
import Development.IDE.Plugin
|
||||
import Development.IDE.Core.Service
|
||||
import Development.IDE.Core.PositionMapping
|
||||
import Development.IDE.Plugin.Completions.Logic
|
||||
@ -27,18 +24,21 @@ import Development.IDE.Core.Shake
|
||||
import Development.IDE.GHC.Compat
|
||||
|
||||
import Development.IDE.GHC.Util
|
||||
import Development.IDE.LSP.Server
|
||||
import TcRnDriver (tcRnImportDecls)
|
||||
import Data.Maybe
|
||||
import Ide.Plugin.Config (Config (completionSnippetsOn))
|
||||
import Ide.PluginUtils (getClientConfig)
|
||||
import Ide.Types
|
||||
|
||||
#if defined(GHC_LIB)
|
||||
import Development.IDE.Import.DependencyInformation
|
||||
#endif
|
||||
|
||||
plugin :: Plugin Config
|
||||
plugin = Plugin produceCompletions setHandlersCompletion
|
||||
descriptor :: PluginId -> PluginDescriptor IdeState
|
||||
descriptor plId = (defaultPluginDescriptor plId)
|
||||
{ pluginRules = produceCompletions
|
||||
, pluginCompletionProvider = Just getCompletionsLSP
|
||||
}
|
||||
|
||||
produceCompletions :: Rules ()
|
||||
produceCompletions = do
|
||||
@ -150,7 +150,3 @@ getCompletionsLSP lsp ide
|
||||
_ -> return (Completions $ List [])
|
||||
_ -> return (Completions $ List [])
|
||||
_ -> return (Completions $ List [])
|
||||
setHandlersCompletion :: PartialHandlers Config
|
||||
setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{
|
||||
LSP.completionHandler = withResponse RspCompletion getCompletionsLSP
|
||||
}
|
||||
|
@ -49,11 +49,11 @@ import Development.IDE.GHC.Util
|
||||
import Outputable (Outputable)
|
||||
import qualified Data.Set as Set
|
||||
import ConLike
|
||||
|
||||
import GhcPlugins (
|
||||
flLabel,
|
||||
unpackFS)
|
||||
import Data.Either (fromRight)
|
||||
import Ide.Types(WithSnippets(..))
|
||||
|
||||
-- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs
|
||||
|
||||
@ -443,8 +443,6 @@ findRecordCompl _ _ _ = []
|
||||
ppr :: Outputable a => a -> T.Text
|
||||
ppr = T.pack . prettyPrint
|
||||
|
||||
newtype WithSnippets = WithSnippets Bool
|
||||
|
||||
toggleSnippets :: ClientCapabilities -> WithSnippets -> CompletionItem -> CompletionItem
|
||||
toggleSnippets ClientCapabilities { _textDocument } (WithSnippets with) x
|
||||
| with && supported = x
|
||||
|
@ -32,8 +32,8 @@ import qualified Language.Haskell.LSP.VFS as VFS
|
||||
import Text.Regex.TDFA.Text()
|
||||
import Development.Shake (Rules)
|
||||
import Ide.PluginUtils (getClientConfig, pluginEnabled, getPluginConfig, responseError, getProcessID)
|
||||
import Development.IDE.Types.Logger (logInfo)
|
||||
import Development.IDE.Core.Tracing
|
||||
import Development.IDE.Types.Logger (logDebug)
|
||||
import Control.Concurrent.Async (mapConcurrently)
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
@ -156,7 +156,7 @@ makeCodeLens :: [(PluginId, CodeLensProvider IdeState)]
|
||||
-> CodeLensParams
|
||||
-> IO (Either ResponseError (List CodeLens))
|
||||
makeCodeLens cas lf ideState params = do
|
||||
logInfo (ideLogger ideState) "Plugin.makeCodeLens (ideLogger)" -- AZ
|
||||
logDebug (ideLogger ideState) "Plugin.makeCodeLens (ideLogger)" -- AZ
|
||||
let
|
||||
makeLens (pid, provider) = do
|
||||
pluginConfig <- getPluginConfig lf pid
|
||||
|
@ -4,59 +4,43 @@
|
||||
-- | Exposes the ghcide features as an HLS plugin
|
||||
module Development.IDE.Plugin.HLS.GhcIde
|
||||
(
|
||||
descriptor
|
||||
descriptors
|
||||
) where
|
||||
|
||||
import Data.Aeson
|
||||
import Development.IDE
|
||||
import Development.IDE.Plugin as Ghcide
|
||||
import Development.IDE.Plugin.Completions as Completions
|
||||
import Development.IDE.Plugin.CodeAction as CodeAction
|
||||
import Development.IDE.LSP.HoverDefinition
|
||||
import Development.IDE.LSP.Outline
|
||||
import Ide.PluginUtils
|
||||
import Ide.Types
|
||||
import Language.Haskell.LSP.Types
|
||||
import Text.Regex.TDFA.Text()
|
||||
import qualified Development.IDE.Plugin.CodeAction as CodeAction
|
||||
import qualified Development.IDE.Plugin.Completions as Completions
|
||||
import qualified Development.IDE.Plugin.TypeLenses as TypeLenses
|
||||
|
||||
descriptors :: [PluginDescriptor IdeState]
|
||||
descriptors =
|
||||
[ descriptor "ghcide-hover-and-symbols",
|
||||
CodeAction.descriptor "ghcide-code-actions",
|
||||
Completions.descriptor "ghcide-completions",
|
||||
TypeLenses.descriptor "ghcide-type-lenses"
|
||||
]
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
descriptor :: PluginId -> PluginDescriptor IdeState
|
||||
descriptor plId = (defaultPluginDescriptor plId)
|
||||
{ pluginCommands = [PluginCommand (CommandId "typesignature.add") "adds a signature" commandAddSignature]
|
||||
, pluginCodeActionProvider = Just codeAction'
|
||||
, pluginCodeLensProvider = Just codeLens'
|
||||
, pluginHoverProvider = Just hover'
|
||||
{ pluginHoverProvider = Just hover'
|
||||
, pluginSymbolsProvider = Just symbolsProvider
|
||||
, pluginCompletionProvider = Just getCompletionsLSP
|
||||
, pluginRules = Ghcide.pluginRules Completions.plugin <> Ghcide.pluginRules CodeAction.plugin
|
||||
}
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
hover' :: HoverProvider IdeState
|
||||
hover' ideState params = do
|
||||
logInfo (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ
|
||||
logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ
|
||||
hover ideState params
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
commandAddSignature :: CommandFunction IdeState WorkspaceEdit
|
||||
commandAddSignature lf ide params
|
||||
= commandHandler lf ide (ExecuteCommandParams "typesignature.add" (Just (List [toJSON params])) Nothing)
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
codeAction' :: CodeActionProvider IdeState
|
||||
codeAction' lf ide _ doc range context = fmap List <$> codeAction lf ide doc range context
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
codeLens' :: CodeLensProvider IdeState
|
||||
codeLens' lf ide _ params = codeLens lf ide params
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
|
||||
symbolsProvider :: SymbolsProvider IdeState
|
||||
symbolsProvider ls ide params = do
|
||||
ds <- moduleOutline ls ide params
|
||||
|
@ -5,6 +5,8 @@ module Development.IDE.Plugin.Test
|
||||
( TestRequest(..)
|
||||
, WaitForIdeRuleResult(..)
|
||||
, plugin
|
||||
, blockCommandDescriptor
|
||||
, blockCommandId
|
||||
) where
|
||||
|
||||
import Control.Monad.STM
|
||||
@ -32,6 +34,9 @@ import Data.Bifunctor
|
||||
import Data.Text (pack, Text)
|
||||
import Data.String
|
||||
import Development.IDE.Types.Location (fromUri)
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Ide.Types
|
||||
import qualified Language.Haskell.LSP.Core as LSP
|
||||
|
||||
data TestRequest
|
||||
= BlockSeconds Seconds -- ^ :: Null
|
||||
@ -104,3 +109,20 @@ parseAction "gethieast" fp = Right . isJust <$> use GetHieAst fp
|
||||
parseAction "getDependencies" fp = Right . isJust <$> use GetDependencies fp
|
||||
parseAction "getFileContents" fp = Right . isJust <$> use GetFileContents fp
|
||||
parseAction other _ = return $ Left $ "Cannot parse ide rule: " <> pack (original other)
|
||||
|
||||
-- | a command that blocks forever. Used for testing
|
||||
blockCommandId :: Text
|
||||
blockCommandId = "ghcide.command.block"
|
||||
|
||||
blockCommandDescriptor :: PluginId -> PluginDescriptor state
|
||||
blockCommandDescriptor plId = (defaultPluginDescriptor plId) {
|
||||
pluginCommands = [PluginCommand (CommandId blockCommandId) "blocks forever" blockCommandHandler]
|
||||
}
|
||||
|
||||
blockCommandHandler :: CommandFunction state ExecuteCommandParams
|
||||
blockCommandHandler lsp _ideState _params
|
||||
= do
|
||||
LSP.sendFunc lsp $ NotCustomServer $
|
||||
NotificationMessage "2.0" (CustomServerMethod "ghcide/blocking/command") Null
|
||||
threadDelay maxBound
|
||||
return (Right Null, Nothing)
|
||||
|
115
ghcide/src/Development/IDE/Plugin/TypeLenses.hs
Normal file
115
ghcide/src/Development/IDE/Plugin/TypeLenses.hs
Normal file
@ -0,0 +1,115 @@
|
||||
-- | An HLS plugin to provide code lenses for type signatures
|
||||
module Development.IDE.Plugin.TypeLenses
|
||||
( descriptor,
|
||||
suggestSignature,
|
||||
typeLensCommandId,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Aeson.Types (Value (..), toJSON)
|
||||
import qualified Data.HashMap.Strict as Map
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE.Core.RuleTypes (TypeCheck (TypeCheck))
|
||||
import Development.IDE.Core.Rules (IdeState, runAction)
|
||||
import Development.IDE.Core.Service (getDiagnostics)
|
||||
import Development.IDE.Core.Shake (getHiddenDiagnostics, use)
|
||||
import Development.IDE.Types.Location
|
||||
( Position (Position, _character, _line),
|
||||
Range (Range, _end, _start),
|
||||
toNormalizedFilePath',
|
||||
uriToFilePath',
|
||||
)
|
||||
import Ide.PluginUtils (mkLspCommand)
|
||||
import Ide.Types
|
||||
( CommandFunction,
|
||||
CommandId (CommandId),
|
||||
PluginCommand (PluginCommand),
|
||||
PluginDescriptor (pluginCodeLensProvider, pluginCommands),
|
||||
PluginId,
|
||||
defaultPluginDescriptor,
|
||||
)
|
||||
import qualified Language.Haskell.LSP.Core as LSP
|
||||
import Language.Haskell.LSP.Types
|
||||
( ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),
|
||||
CodeLens (CodeLens),
|
||||
CodeLensParams (CodeLensParams, _textDocument),
|
||||
Diagnostic (..),
|
||||
List (..),
|
||||
ResponseError,
|
||||
ServerMethod (WorkspaceApplyEdit),
|
||||
TextDocumentIdentifier (TextDocumentIdentifier),
|
||||
TextEdit (TextEdit),
|
||||
WorkspaceEdit (WorkspaceEdit),
|
||||
)
|
||||
import Text.Regex.TDFA ((=~))
|
||||
|
||||
typeLensCommandId :: T.Text
|
||||
typeLensCommandId = "typesignature.add"
|
||||
|
||||
descriptor :: PluginId -> PluginDescriptor IdeState
|
||||
descriptor plId =
|
||||
(defaultPluginDescriptor plId)
|
||||
{ pluginCodeLensProvider = Just codeLensProvider,
|
||||
pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler]
|
||||
}
|
||||
|
||||
codeLensProvider ::
|
||||
LSP.LspFuncs c ->
|
||||
IdeState ->
|
||||
PluginId ->
|
||||
CodeLensParams ->
|
||||
IO (Either ResponseError (List CodeLens))
|
||||
codeLensProvider _lsp ideState pId CodeLensParams {_textDocument = TextDocumentIdentifier uri} = do
|
||||
fmap (Right . List) $ case uriToFilePath' uri of
|
||||
Just (toNormalizedFilePath' -> filePath) -> do
|
||||
_ <- runAction "codeLens" ideState (use TypeCheck filePath)
|
||||
diag <- getDiagnostics ideState
|
||||
hDiag <- getHiddenDiagnostics ideState
|
||||
sequence
|
||||
[ generateLens pId _range title edit
|
||||
| (dFile, _, dDiag@Diagnostic {_range = _range}) <- diag ++ hDiag,
|
||||
dFile == filePath,
|
||||
(title, tedit) <- suggestSignature False dDiag,
|
||||
let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
|
||||
]
|
||||
Nothing -> pure []
|
||||
|
||||
generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> IO CodeLens
|
||||
generateLens pId _range title edit = do
|
||||
cId <- mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit])
|
||||
return $ CodeLens _range (Just cId) Nothing
|
||||
|
||||
commandHandler :: CommandFunction IdeState WorkspaceEdit
|
||||
commandHandler _lsp _ideState wedit =
|
||||
return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
|
||||
|
||||
suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
|
||||
suggestSignature isQuickFix Diagnostic {_range = _range@Range {..}, ..}
|
||||
| _message
|
||||
=~ ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text) =
|
||||
let signature =
|
||||
removeInitialForAll $
|
||||
T.takeWhile (\x -> x /= '*' && x /= '•') $
|
||||
T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
|
||||
startOfLine = Position (_line _start) startCharacter
|
||||
beforeLine = Range startOfLine startOfLine
|
||||
title = if isQuickFix then "add signature: " <> signature else signature
|
||||
action = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " "
|
||||
in [(title, [action])]
|
||||
where
|
||||
removeInitialForAll :: T.Text -> T.Text
|
||||
removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))
|
||||
| "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))
|
||||
| otherwise = nm <> ty
|
||||
startCharacter
|
||||
| "Polymorphic local binding" `T.isPrefixOf` _message =
|
||||
_character _start
|
||||
| otherwise =
|
||||
0
|
||||
suggestSignature _ _ = []
|
||||
|
||||
unifySpaces :: T.Text -> T.Text
|
||||
unifySpaces = T.unwords . T.words
|
||||
|
||||
filterNewlines :: T.Text -> T.Text
|
||||
filterNewlines = T.concat . T.lines
|
@ -28,6 +28,7 @@ import Development.IDE.Core.Shake (Q(..))
|
||||
import Development.IDE.GHC.Util
|
||||
import qualified Data.Text as T
|
||||
import Data.Typeable
|
||||
import Development.IDE.Plugin.TypeLenses (typeLensCommandId)
|
||||
import Development.IDE.Spans.Common
|
||||
import Development.IDE.Test
|
||||
import Development.IDE.Test.Runfiles
|
||||
@ -59,8 +60,8 @@ import Test.Tasty.Ingredients.Rerun
|
||||
import Test.Tasty.HUnit
|
||||
import Test.Tasty.QuickCheck
|
||||
import System.Time.Extra
|
||||
import Development.IDE.Plugin.CodeAction (typeSignatureCommandId, blockCommandId, matchRegExMultipleImports)
|
||||
import Development.IDE.Plugin.Test (WaitForIdeRuleResult(..), TestRequest(BlockSeconds,GetInterfaceFilesDir))
|
||||
import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports)
|
||||
import Development.IDE.Plugin.Test (TestRequest (BlockSeconds, GetInterfaceFilesDir), WaitForIdeRuleResult (..), blockCommandId)
|
||||
import Control.Monad.Extra (whenJust)
|
||||
import qualified Language.Haskell.LSP.Types.Lens as L
|
||||
import Control.Lens ((^.))
|
||||
@ -141,7 +142,7 @@ initializeResponseTests = withResource acquire release tests where
|
||||
, chk "NO doc link" _documentLinkProvider Nothing
|
||||
, chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
|
||||
, chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
|
||||
, che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List [typeSignatureCommandId, blockCommandId])
|
||||
, che " execute command" _executeCommandProvider [blockCommandId, typeLensCommandId]
|
||||
, chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
|
||||
, chk "NO experimental" _experimental Nothing
|
||||
] where
|
||||
@ -157,13 +158,13 @@ initializeResponseTests = withResource acquire release tests where
|
||||
chk title getActual expected =
|
||||
testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
|
||||
|
||||
che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> Maybe ExecuteCommandOptions -> TestTree
|
||||
che title getActual _expected = testCase title doTest
|
||||
che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree
|
||||
che title getActual expected = testCase title doTest
|
||||
where
|
||||
doTest = do
|
||||
ir <- getInitializeResponse
|
||||
let Just ExecuteCommandOptions {_commands = List [command]} = getActual $ innerCaps ir
|
||||
True @=? T.isSuffixOf "typesignature.add" command
|
||||
let Just ExecuteCommandOptions {_commands = List commands} = getActual $ innerCaps ir
|
||||
zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) expected commands
|
||||
|
||||
|
||||
innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
|
||||
|
Loading…
Reference in New Issue
Block a user