From ce26fd66175a9c266149fceca9e4a37e54168ab9 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Sat, 22 May 2021 21:10:42 +0800 Subject: [PATCH 1/3] Split ghcide actions into different descriptors --- .../src/Development/IDE/Plugin/CodeAction.hs | 104 ++--- .../Development/IDE/Plugin/CodeAction/Args.hs | 395 ++++++++---------- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 5 +- 3 files changed, 224 insertions(+), 280 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 11136b1aa9..1020045577 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -7,8 +7,11 @@ -- | Go to the definition of a variable. module Development.IDE.Plugin.CodeAction - ( descriptor - + ( + iePluginDescriptor, + typeSigsPluginDescriptor, + bindingsPluginDescriptor, + fillHolePluginDescriptor -- * For testing , matchRegExMultipleImports ) where @@ -18,7 +21,6 @@ import Bag (bagToList, import Control.Applicative ((<|>)) import Control.Arrow (second, (>>>)) -import Control.Concurrent.Extra (readVar) import Control.Monad (guard, join) import Control.Monad.IO.Class import Data.Char @@ -39,21 +41,17 @@ import Data.Tuple.Extra (fst3) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Rules import Development.IDE.Core.Service -import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Error -import Development.IDE.GHC.ExactPrint import Development.IDE.GHC.Util (prettyPrint, printRdrName, unsafePrintSDoc) import Development.IDE.Plugin.CodeAction.Args import Development.IDE.Plugin.CodeAction.ExactPrint import Development.IDE.Plugin.CodeAction.PositionIndexed -import Development.IDE.Plugin.TypeLenses (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs), - suggestSignature) +import Development.IDE.Plugin.TypeLenses (suggestSignature) import Development.IDE.Spans.Common import Development.IDE.Types.Exports -import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified GHC.LanguageExtensions as Lang @@ -79,12 +77,7 @@ import TcRnTypes (ImportAvails import Text.Regex.TDFA (mrAfter, (=~), (=~~)) -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = - (defaultPluginDescriptor plId) - { pluginRules = mempty, - pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction - } +------------------------------------------------------------------------------------------------- -- | Generate code actions. codeAction @@ -98,60 +91,55 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range Cod let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents mbFile = toNormalizedFilePath' <$> uriToFilePath uri diag <- fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state - (ideOptions, join -> parsedModule, join -> env, join -> annotatedPS, join -> tcM, join -> har, join -> bindings, join -> gblSigs) <- runAction "CodeAction" state $ - (,,,,,,,) <$> getIdeOptions - <*> getParsedModule `traverse` mbFile - <*> use GhcSession `traverse` mbFile - <*> use GetAnnotatedParsedSource `traverse` mbFile - <*> use TypeCheck `traverse` mbFile - <*> use GetHieAst `traverse` mbFile - <*> use GetBindings `traverse` mbFile - <*> use GetGlobalBindingTypeSigs `traverse` mbFile - -- This is quite expensive 0.6-0.7s on GHC - pkgExports <- maybe mempty envPackageExports env - localExports <- readVar (exportsMap $ shakeExtras state) + (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile let - exportsMap = localExports <> pkgExports - df = ms_hspp_opts . pm_mod_summary <$> parsedModule - actions = - [ mkCA title kind isPreferred [x] edit - | x <- xs, (title, kind, isPreferred, tedit) <- suggestAction $ CodeActionArgs exportsMap ideOptions parsedModule text df annotatedPS tcM har bindings gblSigs x - , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing - ] - actions' = caRemoveRedundantImports parsedModule text diag xs uri - <> actions + actions = caRemoveRedundantImports parsedModule text diag xs uri <> caRemoveInvalidExports parsedModule text diag xs uri - pure $ Right $ List actions' - -mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction) -mkCA title kind isPreferred diags edit = - InR $ CodeAction title kind (Just $ List diags) isPreferred Nothing (Just edit) Nothing Nothing - -suggestAction :: CodeActionArgs -> GhcideCodeActions -suggestAction caa = - concat -- Order these suggestions by priority - [ wrap $ suggestSignature True - , wrap suggestExtendImport - , wrap suggestImportDisambiguation - , wrap suggestNewOrExtendImportForClassMethod + pure $ Right $ List actions + +------------------------------------------------------------------------------------------------- + +iePluginDescriptor :: PluginId -> PluginDescriptor IdeState +iePluginDescriptor plId = + let old = + mkGhcideCAsPlugin [ + wrap suggestExtendImport + , wrap suggestImportDisambiguation + , wrap suggestNewOrExtendImportForClassMethod + , wrap suggestNewImport + , wrap suggestModuleTypo + , wrap suggestFixConstructorImport + , wrap suggestHideShadow + , wrap suggestExportUnusedTopBinding + + ] + plId + in old {pluginHandlers = pluginHandlers old <> mkPluginHandler STextDocumentCodeAction codeAction} + +typeSigsPluginDescriptor :: PluginId -> PluginDescriptor IdeState +typeSigsPluginDescriptor = + mkGhcideCAsPlugin [ + wrap $ suggestSignature True , wrap suggestFillTypeWildcard - , wrap suggestFixConstructorImport - , wrap suggestModuleTypo - , wrap suggestReplaceIdentifier , wrap removeRedundantConstraints , wrap suggestAddTypeAnnotationToSatisfyContraints , wrap suggestConstraint + , wrap suggestModuleTypo + ] + +bindingsPluginDescriptor :: PluginId -> PluginDescriptor IdeState +bindingsPluginDescriptor = + mkGhcideCAsPlugin [ + wrap suggestReplaceIdentifier , wrap suggestImplicitParameter - , wrap suggestHideShadow , wrap suggestNewDefinition - , wrap suggestNewImport , wrap suggestDeleteUnusedBinding - , wrap suggestExportUnusedTopBinding - , wrap suggestFillHole -- Lowest priority ] - where - wrap :: ToCodeAction a => a -> GhcideCodeActions - wrap = toCodeAction caa + +fillHolePluginDescriptor :: PluginId -> PluginDescriptor IdeState +fillHolePluginDescriptor = mkGhcideCAPlugin $ wrap suggestFillHole + +------------------------------------------------------------------------------------------------- findSigOfDecl :: (IdP p -> Bool) -> [LHsDecl p] -> Maybe (Sig p) findSigOfDecl pred decls = diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs index a5d29bce7e..e2d4ba3c0f 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -1,296 +1,249 @@ {-# LANGUAGE FlexibleInstances #-} module Development.IDE.Plugin.CodeAction.Args - ( module Development.IDE.Plugin.CodeAction.Args, + ( CodeActionTitle, + CodeActionPreferred, + GhcideCodeActionResult, + GhcideCodeAction, + mkGhcideCAPlugin, + mkGhcideCAsPlugin, + ToTextEdit(..), + ToCodeAction(..), + wrap, + mkCA, ) where -import Control.Lens (alaf) -import Data.Monoid (Ap (..)) +import Control.Concurrent.Extra +import Control.Monad.Reader +import Control.Monad.Trans.Maybe +import Data.Either (fromRight) +import qualified Data.HashMap.Strict as Map +import Data.IORef.Extra +import Data.Maybe (fromMaybe) import qualified Data.Text as T -import Development.IDE (Diagnostic, - HieAstResult, - TcModuleResult) -import Development.IDE.GHC.Compat (DynFlags, - ParsedModule, - ParsedSource) +import Development.IDE hiding + (pluginHandlers) +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat +import Development.IDE.GHC.ExactPrint import Development.IDE.Plugin.CodeAction.ExactPrint (Rewrite, rewriteToEdit) -import Development.IDE.Plugin.TypeLenses (GlobalBindingTypeSigsResult) +import Development.IDE.Plugin.TypeLenses (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs), + GlobalBindingTypeSigsResult) import Development.IDE.Spans.LocalBindings (Bindings) import Development.IDE.Types.Exports (ExportsMap) import Development.IDE.Types.Options (IdeOptions) -import Language.LSP.Types (CodeActionKind (CodeActionQuickFix), - TextEdit) -import Retrie (Annotated (astA)) -import Retrie.ExactPrint (annsA) +import Ide.Plugin.Config (Config) +import Ide.Types +import qualified Language.LSP.Server as LSP +import Language.LSP.Types type CodeActionTitle = T.Text type CodeActionPreferred = Bool --- | A compact representation of 'Language.LSP.Types.CodeAction's -type GhcideCodeActions = [(CodeActionTitle, Maybe CodeActionKind, Maybe CodeActionPreferred, [TextEdit])] +type GhcideCodeActionResult = [(CodeActionTitle, Maybe CodeActionKind, Maybe CodeActionPreferred, [TextEdit])] + +type GhcideCodeAction = ReaderT CodeActionArgs IO GhcideCodeActionResult + +------------------------------------------------------------------------------------------------- + +{-# ANN runGhcideCodeAction ("HLint: ignore Move guards forward" :: String) #-} +runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult +runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List diags}) codeAction = do + let + mbFile = toNormalizedFilePath' <$> uriToFilePath uri + runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key + caaExportsMap <- onceIO $ runRule GhcSession >>= \case + Just env -> do + pkgExports<-envPackageExports env + localExports <- readVar (exportsMap $ shakeExtras state) + pure $ localExports <> pkgExports + _ -> pure mempty + caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions + caaParsedModule <- onceIO $ runRule GetParsedModule + caaContents <- onceIO $ runRule GetFileContents >>= \case + Just (_, txt) -> pure txt + _ -> pure Nothing + caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule + caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource + caaTmr <- onceIO $ runRule TypeCheck + caaHar <- onceIO $ runRule GetHieAst + caaBindings <- onceIO $ runRule GetBindings + caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs + liftIO $ concat + <$> + sequence + [runReaderT codeAction caa | + caaDiagnostic <- diags, let caa = CodeActionArgs {..}] + +mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction) +mkCA title kind isPreferred diags edit = + InR $ CodeAction title kind (Just $ List diags) isPreferred Nothing (Just edit) Nothing Nothing + +mkGhcideCAPlugin ::GhcideCodeAction -> PluginId -> PluginDescriptor IdeState +mkGhcideCAPlugin codeAction plId= + (defaultPluginDescriptor plId) + { + pluginHandlers = mkPluginHandler STextDocumentCodeAction $ \state _ params@(CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics=List diags}) -> do + results <- runGhcideCodeAction state params codeAction + pure $ Right $ List [ mkCA title kind isPreferred diags edit | + (title, kind, isPreferred, tedit)<-results, + let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing + ] + } + +mkGhcideCAsPlugin :: [GhcideCodeAction] -> PluginId -> PluginDescriptor IdeState +mkGhcideCAsPlugin codeActions = mkGhcideCAPlugin $ mconcat codeActions + +------------------------------------------------------------------------------------------------- class ToTextEdit a where - toTextEdit :: CodeActionArgs -> a -> [TextEdit] + toTextEdit :: CodeActionArgs -> a -> IO [TextEdit] instance ToTextEdit TextEdit where - toTextEdit _ = pure + toTextEdit _ = pure . pure instance ToTextEdit Rewrite where - toTextEdit CodeActionArgs {..} rw - | Just df <- caaDf, - Just ps <- caaAnnSource, - Right x <- rewriteToEdit df (annsA ps) rw = - x - | otherwise = [] + toTextEdit CodeActionArgs {..} rw =fmap (fromMaybe []) $ runMaybeT $ do + df <- MaybeT caaDf + ps <- MaybeT caaAnnSource + let r = rewriteToEdit df (annsA ps) rw + pure $ fromRight [] r instance ToTextEdit a => ToTextEdit [a] where toTextEdit caa = foldMap (toTextEdit caa) instance ToTextEdit a => ToTextEdit (Maybe a) where - toTextEdit caa = maybe [] (toTextEdit caa) + toTextEdit caa = maybe (pure []) (toTextEdit caa) instance (ToTextEdit a, ToTextEdit b) => ToTextEdit (Either a b) where toTextEdit caa = either (toTextEdit caa) (toTextEdit caa) +------------------------------------------------------------------------------------------------- data CodeActionArgs = CodeActionArgs - { caaExportsMap :: ExportsMap, - caaIdeOptions :: IdeOptions, - caaParsedModule :: Maybe ParsedModule, - caaContents :: Maybe T.Text, - caaDf :: Maybe DynFlags, - caaAnnSource :: Maybe (Annotated ParsedSource), - caaTmr :: Maybe TcModuleResult, - caaHar :: Maybe HieAstResult, - caaBindings :: Maybe Bindings, - caaGblSigs :: Maybe GlobalBindingTypeSigsResult, - caaDiagnostics :: Diagnostic + { caaExportsMap :: IO ExportsMap, + caaIdeOptions :: IO IdeOptions, + caaParsedModule :: IO (Maybe ParsedModule), + caaContents :: IO (Maybe T.Text), + caaDf :: IO (Maybe DynFlags), + caaAnnSource :: IO (Maybe (Annotated ParsedSource)), + caaTmr :: IO (Maybe TcModuleResult), + caaHar :: IO (Maybe HieAstResult), + caaBindings :: IO (Maybe Bindings), + caaGblSigs :: IO (Maybe GlobalBindingTypeSigsResult), + caaDiagnostic :: Diagnostic } -rewrite :: - Maybe DynFlags -> - Maybe (Annotated ParsedSource) -> - [(T.Text, [Rewrite])] -> - [(T.Text, [TextEdit])] -rewrite (Just df) (Just ps) r - | Right edit <- - (traverse . traverse) - (alaf Ap foldMap (rewriteToEdit df (annsA ps))) - r = - edit -rewrite _ _ _ = [] +-- | There's no concurrency in each provider, +-- so we don't need to be thread-safe here +onceIO :: MonadIO m => IO a -> m (IO a) +onceIO io = do + var <- liftIO $ newIORef Nothing + pure $ readIORef var >>= \case + Just x -> pure x + _ -> io >>= \x -> writeIORef' var (Just x) >> pure x ------------------------------------------------------------------------------------------------- --- | Given 'CodeActionArgs', @a@ can be converted into the representation of code actions. --- This class is designed to package functions that produce code actions in "Development.IDE.Plugin.CodeAction". --- --- For each field @fld@ of 'CodeActionArgs', we make --- --- @@ --- instance ToCodeAction r => ToCodeAction (fld -> r) --- @@ --- --- where we take the value of @fld@ from 'CodeActionArgs' and then feed it into @(fld -> r)@. --- If @fld@ is @Maybe a@, we make --- --- @@ --- instance ToCodeAction r => ToCodeAction (Maybe a -> r) --- instance ToCodeAction r => ToCodeAction (a -> r) --- @@ + +wrap :: (ToCodeAction a) => a -> GhcideCodeAction +wrap = toCodeAction + class ToCodeAction a where - toCodeAction :: CodeActionArgs -> a -> GhcideCodeActions + toCodeAction :: a -> GhcideCodeAction + +instance ToCodeAction GhcideCodeAction where + toCodeAction = id + +instance Semigroup GhcideCodeAction where + a <> b = toCodeAction [a,b] + +instance Monoid GhcideCodeAction where + mempty = pure [] instance ToCodeAction a => ToCodeAction [a] where - toCodeAction caa = foldMap (toCodeAction caa) + toCodeAction = fmap concat . mapM toCodeAction instance ToCodeAction a => ToCodeAction (Maybe a) where - toCodeAction caa = maybe [] (toCodeAction caa) + toCodeAction = maybe (pure []) toCodeAction instance ToTextEdit a => ToCodeAction (CodeActionTitle, a) where - toCodeAction caa (title, te) = [(title, Just CodeActionQuickFix, Nothing, toTextEdit caa te)] + toCodeAction (title, te) = ReaderT $ \caa -> pure . (title, Just CodeActionQuickFix, Nothing, ) <$> toTextEdit caa te instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, a) where - toCodeAction caa (title, kind, te) = [(title, Just kind, Nothing, toTextEdit caa te)] + toCodeAction (title, kind, te) = ReaderT $ \caa -> pure . (title, Just kind, Nothing, ) <$> toTextEdit caa te instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionPreferred, a) where - toCodeAction caa (title, isPreferred, te) = [(title, Just CodeActionQuickFix, Just isPreferred, toTextEdit caa te)] + toCodeAction (title, isPreferred, te) = ReaderT $ \caa -> pure . (title, Just CodeActionQuickFix, Just isPreferred,) <$> toTextEdit caa te instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, CodeActionPreferred, a) where - toCodeAction caa (title, kind, isPreferred, te) = [(title, Just kind, Just isPreferred, toTextEdit caa te)] + toCodeAction (title, kind, isPreferred, te) = ReaderT $ \caa -> pure . (title, Just kind, Just isPreferred,) <$> toTextEdit caa te ------------------------------------------------------------------------------------------------- --- | Complement: we can obtain 'ParsedSource' from 'caaAnnSource' +toCodeAction1 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a))->(Maybe a ->r) ->GhcideCodeAction +toCodeAction1 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f + +toCodeAction2 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) ->(a ->r)->GhcideCodeAction +toCodeAction2 get f = ReaderT $ \caa -> get caa >>= \case + Just x ->flip runReaderT caa . toCodeAction . f $ x + _ -> pure [] + +toCodeAction3 :: (ToCodeAction r) =>(CodeActionArgs -> IO a) -> (a ->r) ->GhcideCodeAction +toCodeAction3 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where - toCodeAction caa@CodeActionArgs {caaAnnSource = Just ps} f = toCodeAction caa $ f $ astA ps - toCodeAction _ _ = [] - --- The following boilerplate code can be generated by 'mkInstances'. --- Now it was commented out with generated code spliced out, --- because fields of 'CodeActionArgs' don't change frequently. --- --- mkInstances :: Name -> DecsQ --- mkInstances tyConName = --- reify tyConName >>= \case --- (TyConI (DataD _ _ _ _ [RecC dataConName tys] _)) -> concat <$> mapM (genForVar dataConName) tys --- _ -> error "unsupported" --- where --- clsType = conT $ mkName "ToCodeAction" --- methodName = mkName "toCodeAction" --- tempType = varT $ mkName "r" --- commonFun dataConName fieldName = --- funD --- methodName --- [ clause --- [ mkName "caa" --- `asP` recP --- dataConName --- [fieldPat fieldName $ varP (mkName "x")] --- , varP (mkName "f") --- ] --- (normalB [|$(varE methodName) caa $ f x|]) --- [] --- ] --- genForVar dataConName (fieldName, _, ty@(AppT (ConT _maybe) ty')) --- | _maybe == ''Maybe = --- do --- withMaybe <- --- instanceD --- (cxt [clsType `appT` tempType]) --- (clsType `appT` ((arrowT `appT` pure ty) `appT` tempType)) --- [commonFun dataConName fieldName] --- withoutMaybe <- --- instanceD --- (cxt [clsType `appT` tempType]) --- (clsType `appT` ((arrowT `appT` pure ty') `appT` tempType)) --- [ funD --- methodName --- [ clause --- [ mkName "caa" --- `asP` recP --- dataConName --- [fieldPat fieldName $ conP 'Just [varP (mkName "x")]] --- , varP (mkName "f") --- ] --- (normalB [|$(varE methodName) caa $ f x|]) --- [] --- , clause [wildP, wildP] (normalB [|[]|]) [] --- ] --- ] --- pure [withMaybe, withoutMaybe] --- genForVar dataConName (fieldName, _, ty) = --- pure --- <$> instanceD --- (cxt [clsType `appT` tempType]) --- (clsType `appT` ((arrowT `appT` pure ty) `appT` tempType)) --- [commonFun dataConName fieldName] + toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} -> x >>= \case + Just s -> flip runReaderT caa . toCodeAction . f . astA $ s + _ -> pure [] instance ToCodeAction r => ToCodeAction (ExportsMap -> r) where - toCodeAction caa@CodeActionArgs {caaExportsMap = x} f = - toCodeAction caa $ f x - + toCodeAction = toCodeAction3 caaExportsMap instance ToCodeAction r => ToCodeAction (IdeOptions -> r) where - toCodeAction caa@CodeActionArgs {caaIdeOptions = x} f = - toCodeAction caa $ f x + toCodeAction = toCodeAction3 caaIdeOptions + +instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where + toCodeAction f = ReaderT $ \ caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . toCodeAction $ f x -instance - ToCodeAction r => - ToCodeAction (Maybe ParsedModule -> r) - where - toCodeAction caa@CodeActionArgs {caaParsedModule = x} f = - toCodeAction caa $ f x +instance ToCodeAction r => ToCodeAction (Maybe ParsedModule -> r) where + toCodeAction = toCodeAction1 caaParsedModule instance ToCodeAction r => ToCodeAction (ParsedModule -> r) where - toCodeAction caa@CodeActionArgs {caaParsedModule = Just x} f = - toCodeAction caa $ f x - toCodeAction _ _ = [] + toCodeAction = toCodeAction2 caaParsedModule instance ToCodeAction r => ToCodeAction (Maybe T.Text -> r) where - toCodeAction caa@CodeActionArgs {caaContents = x} f = - toCodeAction caa $ f x - + toCodeAction = toCodeAction1 caaContents instance ToCodeAction r => ToCodeAction (T.Text -> r) where - toCodeAction caa@CodeActionArgs {caaContents = Just x} f = - toCodeAction caa $ f x - toCodeAction _ _ = [] + toCodeAction = toCodeAction2 caaContents instance ToCodeAction r => ToCodeAction (Maybe DynFlags -> r) where - toCodeAction caa@CodeActionArgs {caaDf = x} f = - toCodeAction caa $ f x - + toCodeAction = toCodeAction1 caaDf instance ToCodeAction r => ToCodeAction (DynFlags -> r) where - toCodeAction caa@CodeActionArgs {caaDf = Just x} f = - toCodeAction caa $ f x - toCodeAction _ _ = [] - -instance - ToCodeAction r => - ToCodeAction (Maybe (Annotated ParsedSource) -> r) - where - toCodeAction caa@CodeActionArgs {caaAnnSource = x} f = - toCodeAction caa $ f x - -instance - ToCodeAction r => - ToCodeAction (Annotated ParsedSource -> r) - where - toCodeAction caa@CodeActionArgs {caaAnnSource = Just x} f = - toCodeAction caa $ f x - toCodeAction _ _ = [] - -instance - ToCodeAction r => - ToCodeAction (Maybe TcModuleResult -> r) - where - toCodeAction caa@CodeActionArgs {caaTmr = x} f = - toCodeAction caa $ f x + toCodeAction = toCodeAction2 caaDf -instance ToCodeAction r => ToCodeAction (TcModuleResult -> r) where - toCodeAction caa@CodeActionArgs {caaTmr = Just x} f = - toCodeAction caa $ f x - toCodeAction _ _ = [] +instance ToCodeAction r => ToCodeAction (Maybe (Annotated ParsedSource) -> r) where + toCodeAction = toCodeAction1 caaAnnSource +instance ToCodeAction r => ToCodeAction (Annotated ParsedSource -> r) where + toCodeAction = toCodeAction2 caaAnnSource -instance - ToCodeAction r => - ToCodeAction (Maybe HieAstResult -> r) - where - toCodeAction caa@CodeActionArgs {caaHar = x} f = - toCodeAction caa $ f x +instance ToCodeAction r => ToCodeAction (Maybe TcModuleResult -> r) where + toCodeAction = toCodeAction1 caaTmr +instance ToCodeAction r => ToCodeAction (TcModuleResult -> r) where + toCodeAction = toCodeAction2 caaTmr + +instance ToCodeAction r => ToCodeAction (Maybe HieAstResult -> r) where + toCodeAction = toCodeAction1 caaHar instance ToCodeAction r => ToCodeAction (HieAstResult -> r) where - toCodeAction caa@CodeActionArgs {caaHar = Just x} f = - toCodeAction caa $ f x - toCodeAction _ _ = [] + toCodeAction = toCodeAction2 caaHar instance ToCodeAction r => ToCodeAction (Maybe Bindings -> r) where - toCodeAction caa@CodeActionArgs {caaBindings = x} f = - toCodeAction caa $ f x - + toCodeAction = toCodeAction1 caaBindings instance ToCodeAction r => ToCodeAction (Bindings -> r) where - toCodeAction caa@CodeActionArgs {caaBindings = Just x} f = - toCodeAction caa $ f x - toCodeAction _ _ = [] - -instance - ToCodeAction r => - ToCodeAction (Maybe GlobalBindingTypeSigsResult -> r) - where - toCodeAction caa@CodeActionArgs {caaGblSigs = x} f = - toCodeAction caa $ f x - -instance - ToCodeAction r => - ToCodeAction (GlobalBindingTypeSigsResult -> r) - where - toCodeAction caa@CodeActionArgs {caaGblSigs = Just x} f = - toCodeAction caa $ f x - toCodeAction _ _ = [] + toCodeAction = toCodeAction2 caaBindings +instance ToCodeAction r => ToCodeAction (Maybe GlobalBindingTypeSigsResult -> r) where + toCodeAction = toCodeAction1 caaGblSigs -instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where - toCodeAction caa@CodeActionArgs {caaDiagnostics = x} f = - toCodeAction caa $ f x - -------------------------------------------------------------------------------------------------- +instance ToCodeAction r => ToCodeAction (GlobalBindingTypeSigsResult -> r) where + toCodeAction = toCodeAction2 caaGblSigs diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index 4d9a6b3877..c854330d9c 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -22,7 +22,10 @@ import Text.Regex.TDFA.Text () descriptors :: [PluginDescriptor IdeState] descriptors = [ descriptor "ghcide-hover-and-symbols", - CodeAction.descriptor "ghcide-code-actions", + CodeAction.iePluginDescriptor "ghcide-code-actions-imports-exports", + CodeAction.typeSigsPluginDescriptor "ghcide-code-actions-type-signatures", + CodeAction.bindingsPluginDescriptor "ghcide-code-actions-bindings", + CodeAction.fillHolePluginDescriptor "ghcide-code-actions-fill-holes", Completions.descriptor "ghcide-completions", TypeLenses.descriptor "ghcide-type-lenses", Notifications.descriptor "ghcide-core" From a7ba51500dca7a7afe53eb1106564549be468043 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Sun, 23 May 2021 10:20:04 +0800 Subject: [PATCH 2/3] Fix duplicate of suggestModuleTypo --- ghcide/src/Development/IDE/Plugin/CodeAction.hs | 2 -- ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs | 2 +- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 1020045577..767bf7a768 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -111,7 +111,6 @@ iePluginDescriptor plId = , wrap suggestFixConstructorImport , wrap suggestHideShadow , wrap suggestExportUnusedTopBinding - ] plId in old {pluginHandlers = pluginHandlers old <> mkPluginHandler STextDocumentCodeAction codeAction} @@ -124,7 +123,6 @@ typeSigsPluginDescriptor = , wrap removeRedundantConstraints , wrap suggestAddTypeAnnotationToSatisfyContraints , wrap suggestConstraint - , wrap suggestModuleTypo ] bindingsPluginDescriptor :: PluginId -> PluginDescriptor IdeState diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs index e2d4ba3c0f..b44db3f173 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -57,7 +57,7 @@ runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _ra runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key caaExportsMap <- onceIO $ runRule GhcSession >>= \case Just env -> do - pkgExports<-envPackageExports env + pkgExports <- envPackageExports env localExports <- readVar (exportsMap $ shakeExtras state) pure $ localExports <> pkgExports _ -> pure mempty From cad04a2a11f07093153525c382722dd96c9daa9c Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Sun, 23 May 2021 10:26:23 +0800 Subject: [PATCH 3/3] Reformat --- .../Development/IDE/Plugin/CodeAction/Args.hs | 156 ++++++++++-------- 1 file changed, 88 insertions(+), 68 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs index b44db3f173..5c9cab3e79 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -2,15 +2,15 @@ module Development.IDE.Plugin.CodeAction.Args ( CodeActionTitle, - CodeActionPreferred, - GhcideCodeActionResult, - GhcideCodeAction, - mkGhcideCAPlugin, - mkGhcideCAsPlugin, - ToTextEdit(..), - ToCodeAction(..), - wrap, - mkCA, + CodeActionPreferred, + GhcideCodeActionResult, + GhcideCodeAction, + mkGhcideCAPlugin, + mkGhcideCAsPlugin, + ToTextEdit (..), + ToCodeAction (..), + wrap, + mkCA, ) where @@ -45,53 +45,61 @@ type CodeActionPreferred = Bool type GhcideCodeActionResult = [(CodeActionTitle, Maybe CodeActionKind, Maybe CodeActionPreferred, [TextEdit])] -type GhcideCodeAction = ReaderT CodeActionArgs IO GhcideCodeActionResult +type GhcideCodeAction = ReaderT CodeActionArgs IO GhcideCodeActionResult ------------------------------------------------------------------------------------------------- {-# ANN runGhcideCodeAction ("HLint: ignore Move guards forward" :: String) #-} -runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult -runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List diags}) codeAction = do - let - mbFile = toNormalizedFilePath' <$> uriToFilePath uri - runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key - caaExportsMap <- onceIO $ runRule GhcSession >>= \case - Just env -> do - pkgExports <- envPackageExports env - localExports <- readVar (exportsMap $ shakeExtras state) - pure $ localExports <> pkgExports - _ -> pure mempty +runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult +runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = List diags}) codeAction = do + let mbFile = toNormalizedFilePath' <$> uriToFilePath uri + runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key + caaExportsMap <- + onceIO $ + runRule GhcSession >>= \case + Just env -> do + pkgExports <- envPackageExports env + localExports <- readVar (exportsMap $ shakeExtras state) + pure $ localExports <> pkgExports + _ -> pure mempty caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions caaParsedModule <- onceIO $ runRule GetParsedModule - caaContents <- onceIO $ runRule GetFileContents >>= \case - Just (_, txt) -> pure txt - _ -> pure Nothing + caaContents <- + onceIO $ + runRule GetFileContents >>= \case + Just (_, txt) -> pure txt + _ -> pure Nothing caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource caaTmr <- onceIO $ runRule TypeCheck caaHar <- onceIO $ runRule GetHieAst caaBindings <- onceIO $ runRule GetBindings caaGblSigs <- onceIO $ runRule GetGlobalBindingTypeSigs - liftIO $ concat - <$> - sequence - [runReaderT codeAction caa | - caaDiagnostic <- diags, let caa = CodeActionArgs {..}] + liftIO $ + concat + <$> sequence + [ runReaderT codeAction caa + | caaDiagnostic <- diags, + let caa = CodeActionArgs {..} + ] mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction) mkCA title kind isPreferred diags edit = InR $ CodeAction title kind (Just $ List diags) isPreferred Nothing (Just edit) Nothing Nothing -mkGhcideCAPlugin ::GhcideCodeAction -> PluginId -> PluginDescriptor IdeState -mkGhcideCAPlugin codeAction plId= +mkGhcideCAPlugin :: GhcideCodeAction -> PluginId -> PluginDescriptor IdeState +mkGhcideCAPlugin codeAction plId = (defaultPluginDescriptor plId) - { - pluginHandlers = mkPluginHandler STextDocumentCodeAction $ \state _ params@(CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics=List diags}) -> do - results <- runGhcideCodeAction state params codeAction - pure $ Right $ List [ mkCA title kind isPreferred diags edit | - (title, kind, isPreferred, tedit)<-results, - let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing - ] + { pluginHandlers = mkPluginHandler STextDocumentCodeAction $ + \state _ params@(CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext {_diagnostics = List diags}) -> do + results <- runGhcideCodeAction state params codeAction + pure $ + Right $ + List + [ mkCA title kind isPreferred diags edit + | (title, kind, isPreferred, tedit) <- results, + let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing + ] } mkGhcideCAsPlugin :: [GhcideCodeAction] -> PluginId -> PluginDescriptor IdeState @@ -106,11 +114,12 @@ instance ToTextEdit TextEdit where toTextEdit _ = pure . pure instance ToTextEdit Rewrite where - toTextEdit CodeActionArgs {..} rw =fmap (fromMaybe []) $ runMaybeT $ do - df <- MaybeT caaDf - ps <- MaybeT caaAnnSource - let r = rewriteToEdit df (annsA ps) rw - pure $ fromRight [] r + toTextEdit CodeActionArgs {..} rw = fmap (fromMaybe []) $ + runMaybeT $ do + df <- MaybeT caaDf + ps <- MaybeT caaAnnSource + let r = rewriteToEdit df (annsA ps) rw + pure $ fromRight [] r instance ToTextEdit a => ToTextEdit [a] where toTextEdit caa = foldMap (toTextEdit caa) @@ -120,6 +129,7 @@ instance ToTextEdit a => ToTextEdit (Maybe a) where instance (ToTextEdit a, ToTextEdit b) => ToTextEdit (Either a b) where toTextEdit caa = either (toTextEdit caa) (toTextEdit caa) + ------------------------------------------------------------------------------------------------- data CodeActionArgs = CodeActionArgs @@ -136,17 +146,17 @@ data CodeActionArgs = CodeActionArgs caaDiagnostic :: Diagnostic } - -- | There's no concurrency in each provider, -- so we don't need to be thread-safe here onceIO :: MonadIO m => IO a -> m (IO a) onceIO io = do var <- liftIO $ newIORef Nothing - pure $ readIORef var >>= \case - Just x -> pure x - _ -> io >>= \x -> writeIORef' var (Just x) >> pure x -------------------------------------------------------------------------------------------------- + pure $ + readIORef var >>= \case + Just x -> pure x + _ -> io >>= \x -> writeIORef' var (Just x) >> pure x +------------------------------------------------------------------------------------------------- wrap :: (ToCodeAction a) => a -> GhcideCodeAction wrap = toCodeAction @@ -158,72 +168,79 @@ instance ToCodeAction GhcideCodeAction where toCodeAction = id instance Semigroup GhcideCodeAction where - a <> b = toCodeAction [a,b] + a <> b = toCodeAction [a, b] instance Monoid GhcideCodeAction where mempty = pure [] instance ToCodeAction a => ToCodeAction [a] where - toCodeAction = fmap concat . mapM toCodeAction + toCodeAction = fmap concat . mapM toCodeAction instance ToCodeAction a => ToCodeAction (Maybe a) where - toCodeAction = maybe (pure []) toCodeAction + toCodeAction = maybe (pure []) toCodeAction instance ToTextEdit a => ToCodeAction (CodeActionTitle, a) where - toCodeAction (title, te) = ReaderT $ \caa -> pure . (title, Just CodeActionQuickFix, Nothing, ) <$> toTextEdit caa te + toCodeAction (title, te) = ReaderT $ \caa -> pure . (title,Just CodeActionQuickFix,Nothing,) <$> toTextEdit caa te instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, a) where - toCodeAction (title, kind, te) = ReaderT $ \caa -> pure . (title, Just kind, Nothing, ) <$> toTextEdit caa te + toCodeAction (title, kind, te) = ReaderT $ \caa -> pure . (title,Just kind,Nothing,) <$> toTextEdit caa te instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionPreferred, a) where - toCodeAction (title, isPreferred, te) = ReaderT $ \caa -> pure . (title, Just CodeActionQuickFix, Just isPreferred,) <$> toTextEdit caa te + toCodeAction (title, isPreferred, te) = ReaderT $ \caa -> pure . (title,Just CodeActionQuickFix,Just isPreferred,) <$> toTextEdit caa te instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, CodeActionPreferred, a) where - toCodeAction (title, kind, isPreferred, te) = ReaderT $ \caa -> pure . (title, Just kind, Just isPreferred,) <$> toTextEdit caa te + toCodeAction (title, kind, isPreferred, te) = ReaderT $ \caa -> pure . (title,Just kind,Just isPreferred,) <$> toTextEdit caa te ------------------------------------------------------------------------------------------------- -toCodeAction1 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a))->(Maybe a ->r) ->GhcideCodeAction -toCodeAction1 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f +toCodeAction1 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (Maybe a -> r) -> GhcideCodeAction +toCodeAction1 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f -toCodeAction2 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) ->(a ->r)->GhcideCodeAction -toCodeAction2 get f = ReaderT $ \caa -> get caa >>= \case - Just x ->flip runReaderT caa . toCodeAction . f $ x - _ -> pure [] +toCodeAction2 :: (ToCodeAction r) => (CodeActionArgs -> IO (Maybe a)) -> (a -> r) -> GhcideCodeAction +toCodeAction2 get f = ReaderT $ \caa -> + get caa >>= \case + Just x -> flip runReaderT caa . toCodeAction . f $ x + _ -> pure [] -toCodeAction3 :: (ToCodeAction r) =>(CodeActionArgs -> IO a) -> (a ->r) ->GhcideCodeAction +toCodeAction3 :: (ToCodeAction r) => (CodeActionArgs -> IO a) -> (a -> r) -> GhcideCodeAction toCodeAction3 get f = ReaderT $ \caa -> get caa >>= flip runReaderT caa . toCodeAction . f + instance ToCodeAction r => ToCodeAction (ParsedSource -> r) where - toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} -> x >>= \case - Just s -> flip runReaderT caa . toCodeAction . f . astA $ s - _ -> pure [] + toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaAnnSource = x} -> + x >>= \case + Just s -> flip runReaderT caa . toCodeAction . f . astA $ s + _ -> pure [] instance ToCodeAction r => ToCodeAction (ExportsMap -> r) where toCodeAction = toCodeAction3 caaExportsMap + instance ToCodeAction r => ToCodeAction (IdeOptions -> r) where - toCodeAction = toCodeAction3 caaIdeOptions + toCodeAction = toCodeAction3 caaIdeOptions instance ToCodeAction r => ToCodeAction (Diagnostic -> r) where - toCodeAction f = ReaderT $ \ caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . toCodeAction $ f x - + toCodeAction f = ReaderT $ \caa@CodeActionArgs {caaDiagnostic = x} -> flip runReaderT caa . toCodeAction $ f x instance ToCodeAction r => ToCodeAction (Maybe ParsedModule -> r) where toCodeAction = toCodeAction1 caaParsedModule + instance ToCodeAction r => ToCodeAction (ParsedModule -> r) where toCodeAction = toCodeAction2 caaParsedModule instance ToCodeAction r => ToCodeAction (Maybe T.Text -> r) where toCodeAction = toCodeAction1 caaContents + instance ToCodeAction r => ToCodeAction (T.Text -> r) where toCodeAction = toCodeAction2 caaContents instance ToCodeAction r => ToCodeAction (Maybe DynFlags -> r) where toCodeAction = toCodeAction1 caaDf + instance ToCodeAction r => ToCodeAction (DynFlags -> r) where toCodeAction = toCodeAction2 caaDf instance ToCodeAction r => ToCodeAction (Maybe (Annotated ParsedSource) -> r) where toCodeAction = toCodeAction1 caaAnnSource + instance ToCodeAction r => ToCodeAction (Annotated ParsedSource -> r) where toCodeAction = toCodeAction2 caaAnnSource @@ -235,13 +252,16 @@ instance ToCodeAction r => ToCodeAction (TcModuleResult -> r) where instance ToCodeAction r => ToCodeAction (Maybe HieAstResult -> r) where toCodeAction = toCodeAction1 caaHar + instance ToCodeAction r => ToCodeAction (HieAstResult -> r) where toCodeAction = toCodeAction2 caaHar instance ToCodeAction r => ToCodeAction (Maybe Bindings -> r) where toCodeAction = toCodeAction1 caaBindings + instance ToCodeAction r => ToCodeAction (Bindings -> r) where toCodeAction = toCodeAction2 caaBindings + instance ToCodeAction r => ToCodeAction (Maybe GlobalBindingTypeSigsResult -> r) where toCodeAction = toCodeAction1 caaGblSigs