diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 37a0cc4f65..2b465b0c17 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -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" diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 8f090b3d28..582ce2597d 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -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 diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 62a75f56ca..e78f5342d5 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -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 diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index 6aa73574f3..3df7cda806 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -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} diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index fd55e614dc..27747071c0 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -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 <> diff --git a/ghcide/src/Development/IDE/Plugin.hs b/ghcide/src/Development/IDE/Plugin.hs index a7094ac15e..f8822ece32 100644 --- a/ghcide/src/Development/IDE/Plugin.hs +++ b/ghcide/src/Development/IDE/Plugin.hs @@ -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 diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index ab668bb51f..1dbddf9e6a 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -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 diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index e0142f4c8e..4c146c580f 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -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 - } diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index eaf5ea4ca0..cea837eee3 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -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 diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 94166ebe4b..f00d5f9362 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -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 diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index dfcc6e72ed..01a8028c31 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -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 diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index a33fccea49..e4ae111e2f 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -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) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs new file mode 100644 index 0000000000..40a86e5705 --- /dev/null +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -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 diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 277b9fe120..d124a5e77f 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -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 @@ -1171,7 +1172,7 @@ extendImportTests = testGroup "extend import actions" , "import ModuleA (A (Constructor))" , "b :: A" , "b = Constructor" - ]) + ]) , testSession "extend single line import with constructor (with comments)" $ template [("ModuleA.hs", T.unlines [ "module ModuleA where"