From bc2418707c688ef3b6b93e703dc0cb1a7357ae06 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Mon, 1 Mar 2021 20:14:01 +0800 Subject: [PATCH 1/8] Retrieve Type from typecheck result for type lenses --- .../src/Development/IDE/Plugin/CodeAction.hs | 13 +- .../src/Development/IDE/Plugin/TypeLenses.hs | 126 ++++++++++-------- ghcide/src/Development/IDE/Spans/Common.hs | 7 +- 3 files changed, 84 insertions(+), 62 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index ac7bcf5df8..9f7c2fb8ad 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -51,6 +51,7 @@ import Development.IDE.Plugin.CodeAction.ExactPrint import Development.IDE.Plugin.CodeAction.PositionIndexed import Development.IDE.Plugin.TypeLenses (suggestSignature) import Development.IDE.Spans.Common +import Development.IDE.Spans.LocalBindings (Bindings) import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Location @@ -97,13 +98,14 @@ 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) <- runAction "CodeAction" state $ - (,,,,,) <$> getIdeOptions + (ideOptions, join -> parsedModule, join -> env, join -> annotatedPS, join -> tcM, join -> har, join -> bindings) <- 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 -- This is quite expensive 0.6-0.7s on GHC pkgExports <- maybe mempty envPackageExports env localExports <- readVar (exportsMap $ shakeExtras state) @@ -112,7 +114,7 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range Cod df = ms_hspp_opts . pm_mod_summary <$> parsedModule actions = [ mkCA title [x] edit - | x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text df annotatedPS tcM har x + | x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text df annotatedPS tcM har bindings x , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing ] actions' = caRemoveRedundantImports parsedModule text diag xs uri @@ -144,12 +146,13 @@ suggestAction -> Maybe (Annotated ParsedSource) -> Maybe TcModuleResult -> Maybe HieAstResult + -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] -suggestAction packageExports ideOptions parsedModule text df annSource tcM har diag = +suggestAction packageExports ideOptions parsedModule text df annSource tcM har bindings diag = concat -- Order these suggestions by priority - [ suggestSignature True diag + [ suggestSignature True tcM bindings diag , rewrite df annSource $ \_ ps -> suggestExtendImport packageExports ps diag , rewrite df annSource $ \df ps -> suggestImportDisambiguation df text ps diag diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index d9cdc4c220..bc92b551f7 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -6,36 +6,51 @@ module Development.IDE.Plugin.TypeLenses ) where +import Control.Applicative ((<|>)) import Control.Monad.IO.Class -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 (..), - PluginId, - defaultPluginDescriptor, - mkPluginHandler) -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), - CodeLens (CodeLens), - CodeLensParams (CodeLensParams, _textDocument), - Diagnostic (..), List (..), - ResponseError, SMethod (..), - TextDocumentIdentifier (TextDocumentIdentifier), - TextEdit (TextEdit), - WorkspaceEdit (WorkspaceEdit)) -import Text.Regex.TDFA ((=~)) +import Data.Aeson.Types (Value (..), toJSON) +import Data.Generics (mkQ, something) +import qualified Data.HashMap.Strict as Map +import Data.List (find) +import qualified Data.Text as T +import Development.IDE.Core.Compile (TcModuleResult (..)) +import Development.IDE.Core.RuleTypes (GetBindings (GetBindings), + 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.GHC.Compat +import Development.IDE.GHC.Util (printName) +import Development.IDE.Spans.Common (safeTyThingType) +import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope) +import Development.IDE.Types.Location (Position (Position, _character, _line), + Range (Range, _end, _start), + toNormalizedFilePath', + uriToFilePath') +import HscTypes (lookupTypeEnv, + mkPrintUnqualified) +import Ide.PluginUtils (mkLspCommand) +import Ide.Types (CommandFunction, + CommandId (CommandId), + PluginCommand (PluginCommand), + PluginDescriptor (..), + PluginId, + defaultPluginDescriptor, + mkPluginHandler) +import qualified Language.LSP.Server as LSP +import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), + CodeLens (CodeLens), + CodeLensParams (CodeLensParams, _textDocument), + Diagnostic (..), + List (..), ResponseError, + SMethod (..), + TextDocumentIdentifier (TextDocumentIdentifier), + TextEdit (TextEdit), + WorkspaceEdit (WorkspaceEdit)) +import Outputable (showSDocForUser) +import TcRnTypes (TcGblEnv (TcGblEnv, tcg_rdr_env, tcg_rn_decls, tcg_type_env)) +import TcType (pprSigmaType) +import Text.Regex.TDFA ((=~)) typeLensCommandId :: T.Text typeLensCommandId = "typesignature.add" @@ -55,14 +70,15 @@ codeLensProvider :: codeLensProvider ideState pId CodeLensParams {_textDocument = TextDocumentIdentifier uri} = do fmap (Right . List) $ case uriToFilePath' uri of Just (toNormalizedFilePath' -> filePath) -> liftIO $ do - _ <- runAction "codeLens" ideState (use TypeCheck filePath) + tmr <- runAction "codeLens.TypeCheck" ideState (use TypeCheck filePath) + bindings <- runAction "bindings.GetBindings" ideState (use GetBindings 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, + (title, tedit) <- suggestSignature False tmr bindings dDiag, let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing ] Nothing -> pure [] @@ -77,33 +93,37 @@ commandHandler _ideState wedit = do _ <- LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) return $ Right Null -suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])] -suggestSignature isQuickFix Diagnostic {_range = _range@Range {..}, ..} +suggestSignature :: Bool -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] +suggestSignature isQuickFix mTmr mBindings Diagnostic {_message, _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])] + =~ ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text), + Just bindings <- mBindings, + Just TcModuleResult {tmrTypechecked = TcGblEnv {tcg_type_env, tcg_rn_decls, tcg_rdr_env}} <- mTmr, + localScope <- getFuzzyScope bindings _start _end, + Just group <- tcg_rn_decls, + Just name <- getFirstIdAtLine (succ $ _line _start) group, + Just ty <- (lookupTypeEnv tcg_type_env name >>= safeTyThingType) <|> (find (\(x, _) -> x == name) localScope >>= snd), + tyMsg <- showSDocForUser unsafeGlobalDynFlags (mkPrintUnqualified unsafeGlobalDynFlags tcg_rdr_env) $ pprSigmaType ty, + signature <- T.pack $ printName name <> " :: " <> tyMsg, + 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 " " = + [(title, [action])] + | otherwise = [] 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 +getFirstIdAtLine :: Int -> HsGroup GhcRn -> Maybe Name +getFirstIdAtLine line = something (mkQ Nothing f) + where + f :: Located Name -> Maybe Name + f (L l name) + | RealSrcSpan s <- l, + srcSpanStartLine s == line = + Just name + | otherwise = Nothing diff --git a/ghcide/src/Development/IDE/Spans/Common.hs b/ghcide/src/Development/IDE/Spans/Common.hs index 855c27c7b2..d03e81c978 100644 --- a/ghcide/src/Development/IDE/Spans/Common.hs +++ b/ghcide/src/Development/IDE/Spans/Common.hs @@ -25,7 +25,6 @@ import qualified Data.Text as T import GHC.Generics import ConLike -import DataCon import DynFlags import GHC import NameEnv @@ -66,9 +65,9 @@ safeTyThingType (ATyCon tycon) = Just (tyConKind tycon) safeTyThingType _ = Nothing safeTyThingId :: TyThing -> Maybe Id -safeTyThingId (AnId i) = Just i -safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc -safeTyThingId _ = Nothing +safeTyThingId (AnId i) = Just i +safeTyThingId (AConLike conLike) = conLikeWrapId_maybe conLike +safeTyThingId _ = Nothing -- Possible documentation for an element in the code data SpanDoc From ae4455b7d886847c100ed21105aea287d13c576a Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Mon, 1 Mar 2021 21:12:52 +0800 Subject: [PATCH 2/8] Fix pattern synonym, add tests --- .../src/Development/IDE/Plugin/TypeLenses.hs | 20 ++++++++++--------- ghcide/test/exe/Main.hs | 2 ++ 2 files changed, 13 insertions(+), 9 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index bc92b551f7..815fff47b9 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -6,6 +6,7 @@ module Development.IDE.Plugin.TypeLenses ) where +import ConLike (ConLike (PatSynCon)) import Control.Applicative ((<|>)) import Control.Monad.IO.Class import Data.Aeson.Types (Value (..), toJSON) @@ -94,7 +95,7 @@ commandHandler _ideState wedit = do return $ Right Null suggestSignature :: Bool -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] -suggestSignature isQuickFix mTmr mBindings Diagnostic {_message, _range = _range@Range {..}} +suggestSignature isQuickFix mTmr mBindings Diagnostic {_message, _range = Range {..}} | _message =~ ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text), Just bindings <- mBindings, @@ -102,21 +103,22 @@ suggestSignature isQuickFix mTmr mBindings Diagnostic {_message, _range = _range localScope <- getFuzzyScope bindings _start _end, Just group <- tcg_rn_decls, Just name <- getFirstIdAtLine (succ $ _line _start) group, - Just ty <- (lookupTypeEnv tcg_type_env name >>= safeTyThingType) <|> (find (\(x, _) -> x == name) localScope >>= snd), + Just (isPatSyn, ty) <- + (lookupTypeEnv tcg_type_env name >>= \x -> (isTyThingPatSyn x,) <$> safeTyThingType x) + <|> ((False,) <$> (find (\(x, _) -> x == name) localScope >>= snd)), tyMsg <- showSDocForUser unsafeGlobalDynFlags (mkPrintUnqualified unsafeGlobalDynFlags tcg_rdr_env) $ pprSigmaType ty, - signature <- T.pack $ printName name <> " :: " <> tyMsg, + signature <- T.pack $ (if isPatSyn then "pattern " else "") <> printName name <> " :: " <> tyMsg, + startCharacter <- if "local binding" `T.isInfixOf` _message then _character _start else 0, 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 " " = [(title, [action])] | otherwise = [] - where - startCharacter - | "Polymorphic local binding" `T.isPrefixOf` _message = - _character _start - | otherwise = - 0 + +isTyThingPatSyn :: TyThing -> Bool +isTyThingPatSyn (AConLike (PatSynCon _)) = True +isTyThingPatSyn _ = False getFirstIdAtLine :: Int -> HsGroup GhcRn -> Maybe Name getFirstIdAtLine line = something (mkQ Nothing f) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 308bf534f6..419fe6cc91 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -3183,6 +3183,8 @@ addSigLensesTests = let , sigSession enableWarnings "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2" , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a" , sigSession enableWarnings "qualifiedSigTest= C.realPart" "qualifiedSigTest :: C.Complex a -> a" + , sigSession enableWarnings "head = 233" "head :: Integer" + , sigSession enableWarnings "a *.* b = a b" "(*.*) :: (t1 -> t2) -> t1 -> t2" ] | (title, enableWarnings) <- [("with warnings enabled", True) From 6c01b8fb33cd6c287a49d9fc5178c2ea195ccc13 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Tue, 2 Mar 2021 12:08:49 +0800 Subject: [PATCH 3/8] Add tests --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 3 ++- ghcide/test/exe/Main.hs | 17 ++++++++++++++--- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 815fff47b9..4988f3d347 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -10,6 +10,7 @@ import ConLike (ConLike (PatSynCon)) import Control.Applicative ((<|>)) import Control.Monad.IO.Class import Data.Aeson.Types (Value (..), toJSON) +import Data.Char (isAlpha) import Data.Generics (mkQ, something) import qualified Data.HashMap.Strict as Map import Data.List (find) @@ -108,7 +109,7 @@ suggestSignature isQuickFix mTmr mBindings Diagnostic {_message, _range = Range <|> ((False,) <$> (find (\(x, _) -> x == name) localScope >>= snd)), tyMsg <- showSDocForUser unsafeGlobalDynFlags (mkPrintUnqualified unsafeGlobalDynFlags tcg_rdr_env) $ pprSigmaType ty, signature <- T.pack $ (if isPatSyn then "pattern " else "") <> printName name <> " :: " <> tyMsg, - startCharacter <- if "local binding" `T.isInfixOf` _message then _character _start else 0, + startCharacter <- if "Polymorphic local" `T.isPrefixOf` T.dropWhile (not . isAlpha) _message then _character _start else 0, startOfLine <- Position (_line _start) startCharacter, beforeLine <- Range startOfLine startOfLine, title <- if isQuickFix then "add signature: " <> signature else signature, diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 419fe6cc91..e59642c45a 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -3157,7 +3157,13 @@ addSigLensesTests :: TestTree addSigLensesTests = let missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}" notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}" - moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where\nimport qualified Data.Complex as C" + moduleH = T.unlines + [ + "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators #-}" + , "module Sigs where" + , "import qualified Data.Complex as C" + , "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)" + ] other = T.unlines ["f :: Integer -> Integer", "f x = 3"] before withMissing def = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other] @@ -3183,8 +3189,13 @@ addSigLensesTests = let , sigSession enableWarnings "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2" , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a" , sigSession enableWarnings "qualifiedSigTest= C.realPart" "qualifiedSigTest :: C.Complex a -> a" - , sigSession enableWarnings "head = 233" "head :: Integer" - , sigSession enableWarnings "a *.* b = a b" "(*.*) :: (t1 -> t2) -> t1 -> t2" + , sigSession enableWarnings "head = 233" "head :: Integer" + , sigSession enableWarnings "rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")" + "rank2Test :: (forall a. a -> a) -> (Int, [Char])" + , sigSession enableWarnings "symbolKindTest = Proxy @\"qwq\"" "symbolKindTest :: Proxy \"qwq\"" + , sigSession enableWarnings "promotedKindTest = Proxy @Nothing" "promotedKindTest :: Proxy 'Nothing" + , sigSession enableWarnings "typeOperatorTest = Refl" "typeOperatorTest :: a :~: a" + , sigSession enableWarnings "notInScopeTest = mkCharType" "notInScopeTest :: String -> Data.Data.DataType" ] | (title, enableWarnings) <- [("with warnings enabled", True) From fbaea2b5219fcc27a05cc3bf25a89e8addc4da5e Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Thu, 4 Mar 2021 15:35:14 +0800 Subject: [PATCH 4/8] Add config for type lenses plugin --- ghcide/src/Development/IDE/Core/Compile.hs | 11 +- .../src/Development/IDE/Plugin/CodeAction.hs | 16 +- .../src/Development/IDE/Plugin/TypeLenses.hs | 231 ++++++++++++++---- 3 files changed, 195 insertions(+), 63 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index f8fdcd36c4..03d03af8f1 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -162,8 +162,7 @@ typecheckModule (IdeDefer defer) hsc keep_lbls pm = do modSummary' <- initPlugins hsc modSummary (warnings, tcm) <- withWarnings "typecheck" $ \tweak -> - tcRnModule hsc keep_lbls $ enableTopLevelWarnings - $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'} + tcRnModule hsc keep_lbls $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'} let errorPipeline = unDefer . hideDiag dflags . tagDiag diags = map errorPipeline warnings deferedError = any fst diags @@ -384,14 +383,6 @@ demoteTypeErrorsToWarnings = . (`gopt_set` Opt_DeferTypedHoles) . (`gopt_set` Opt_DeferOutOfScopeVariables) -enableTopLevelWarnings :: ParsedModule -> ParsedModule -enableTopLevelWarnings = - (update_pm_mod_summary . update_hspp_opts) - ((`wopt_set` Opt_WarnMissingPatternSynonymSignatures) . - (`wopt_set` Opt_WarnMissingSignatures)) - -- the line below would show also warnings for let bindings without signature - -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures))) - update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms} diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 9f7c2fb8ad..3fe9b7bb71 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -49,7 +49,9 @@ import Development.IDE.GHC.Util (prettyPrint, printRdrName) import Development.IDE.Plugin.CodeAction.ExactPrint import Development.IDE.Plugin.CodeAction.PositionIndexed -import Development.IDE.Plugin.TypeLenses (suggestSignature) +import Development.IDE.Plugin.TypeLenses (GetGlobalBindingTypeSigs (GetGlobalBindingTypeSigs), + GlobalBindingTypeSigsResult, + suggestSignature) import Development.IDE.Spans.Common import Development.IDE.Spans.LocalBindings (Bindings) import Development.IDE.Types.Exports @@ -98,14 +100,15 @@ 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) <- runAction "CodeAction" state $ - (,,,,,,) <$> getIdeOptions + (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) @@ -114,7 +117,7 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range Cod df = ms_hspp_opts . pm_mod_summary <$> parsedModule actions = [ mkCA title [x] edit - | x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text df annotatedPS tcM har bindings x + | x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text df annotatedPS tcM har bindings gblSigs x , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing ] actions' = caRemoveRedundantImports parsedModule text diag xs uri @@ -147,12 +150,13 @@ suggestAction -> Maybe TcModuleResult -> Maybe HieAstResult -> Maybe Bindings + -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, [TextEdit])] -suggestAction packageExports ideOptions parsedModule text df annSource tcM har bindings diag = +suggestAction packageExports ideOptions parsedModule text df annSource tcM har bindings gblSigs diag = concat -- Order these suggestions by priority - [ suggestSignature True tcM bindings diag + [ suggestSignature True gblSigs tcM bindings diag , rewrite df annSource $ \_ ps -> suggestExtendImport packageExports ps diag , rewrite df annSource $ \df ps -> suggestImportDisambiguation df text ps diag diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 4988f3d347..b5564320a3 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -1,20 +1,33 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TypeFamilies #-} + -- | An HLS plugin to provide code lenses for type signatures module Development.IDE.Plugin.TypeLenses ( descriptor, suggestSignature, typeLensCommandId, + GlobalBindingTypeSig (..), + GetGlobalBindingTypeSigs (..), + GlobalBindingTypeSigsResult (..), ) where -import ConLike (ConLike (PatSynCon)) -import Control.Applicative ((<|>)) -import Control.Monad.IO.Class +import Avail (availsToNameSet) +import Control.DeepSeq (rwhnf) +import Control.Monad (join) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.Aeson as A import Data.Aeson.Types (Value (..), toJSON) -import Data.Char (isAlpha) -import Data.Generics (mkQ, something) +import qualified Data.Aeson.Types as A import qualified Data.HashMap.Strict as Map import Data.List (find) +import Data.Maybe (catMaybes, fromJust, + fromMaybe) import qualified Data.Text as T +import Development.IDE (GhcSession (..), + HscEnvEq (hscEnv), + RuleResult, Rules, define, + srcSpanToRange) import Development.IDE.Core.Compile (TcModuleResult (..)) import Development.IDE.Core.RuleTypes (GetBindings (GetBindings), TypeCheck (TypeCheck)) @@ -29,9 +42,20 @@ import Development.IDE.Types.Location (Position (Position, _chara Range (Range, _end, _start), toNormalizedFilePath', uriToFilePath') -import HscTypes (lookupTypeEnv, - mkPrintUnqualified) -import Ide.PluginUtils (mkLspCommand) +import Development.Shake.Classes +import GHC.Generics (Generic) +import GhcPlugins (GlobalRdrEnv, + HscEnv (hsc_dflags), SDoc, + elemNameSet, getSrcSpan, + idName, lookupTypeEnv, + mkRealSrcLoc, + realSrcLocSpan, + tidyOpenType) +import HscTypes (mkPrintUnqualified) +import Ide.Plugin.Config (Config, + PluginConfig (plcConfig)) +import Ide.PluginUtils (getPluginConfig, + mkLspCommand) import Ide.Types (CommandFunction, CommandId (CommandId), PluginCommand (PluginCommand), @@ -50,9 +74,12 @@ import Language.LSP.Types (ApplyWorkspaceEditParams ( TextEdit (TextEdit), WorkspaceEdit (WorkspaceEdit)) import Outputable (showSDocForUser) -import TcRnTypes (TcGblEnv (TcGblEnv, tcg_rdr_env, tcg_rn_decls, tcg_type_env)) +import PatSyn (patSynName) +import TcEnv (tcInitTidyEnv) +import TcRnMonad (initTcWithGbl) +import TcRnTypes (TcGblEnv (..)) import TcType (pprSigmaType) -import Text.Regex.TDFA ((=~)) +import Text.Regex.TDFA ((=~), (=~~)) typeLensCommandId :: T.Text typeLensCommandId = "typesignature.add" @@ -61,55 +88,99 @@ descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider, - pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] + pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler], + pluginRules = rules } codeLensProvider :: IdeState -> PluginId -> CodeLensParams -> - LSP.LspM c (Either ResponseError (List CodeLens)) + LSP.LspM Config (Either ResponseError (List CodeLens)) codeLensProvider ideState pId CodeLensParams {_textDocument = TextDocumentIdentifier uri} = do + (fromMaybe Enabled . join -> mode) <- fmap (parseCustomConfig . plcConfig) <$> getPluginConfig pId fmap (Right . List) $ case uriToFilePath' uri of Just (toNormalizedFilePath' -> filePath) -> liftIO $ do tmr <- runAction "codeLens.TypeCheck" ideState (use TypeCheck filePath) - bindings <- runAction "bindings.GetBindings" ideState (use GetBindings filePath) + bindings <- runAction "codeLens.GetBindings" ideState (use GetBindings filePath) + gblSigs <- runAction "codeLens.GetGlobalBindingTypeSigs" ideState (use GetGlobalBindingTypeSigs 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 tmr bindings dDiag, - let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing - ] + + let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing + generateLensForGlobal sig@GlobalBindingTypeSig {..} = do + range <- srcSpanToRange $ gbSrcSpan sig + tedit <- gblBindingTypeSigToEdit sig + let wedit = toWorkSpaceEdit [tedit] + pure $ generateLens pId range (T.pack gbRendered) wedit + gblSigs' = maybe [] (\(GlobalBindingTypeSigsResult x) -> x) gblSigs + + case mode of + Enabled -> + pure (catMaybes $ generateLensForGlobal <$> gblSigs') + <> sequence + [ pure $ generateLens pId _range title edit + | (dFile, _, dDiag@Diagnostic {_range = _range}) <- diag ++ hDiag, + dFile == filePath, + (title, tedit) <- suggestLocalSignature False tmr bindings dDiag, + let edit = toWorkSpaceEdit tedit + ] + Exported -> pure $ catMaybes $ generateLensForGlobal <$> filter gbExported gblSigs' + Diagnostics -> do + sequence + [ pure $ generateLens pId _range title edit + | (dFile, _, dDiag@Diagnostic {_range = _range}) <- diag ++ hDiag, + dFile == filePath, + (title, tedit) <- suggestSignature False gblSigs tmr bindings dDiag, + let edit = toWorkSpaceEdit tedit + ] + Disabled -> pure [] Nothing -> pure [] -generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> IO CodeLens -generateLens pId _range title edit = do +generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens +generateLens pId _range title edit = let cId = mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit]) - return $ CodeLens _range (Just cId) Nothing + in CodeLens _range (Just cId) Nothing commandHandler :: CommandFunction IdeState WorkspaceEdit commandHandler _ideState wedit = do _ <- LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) return $ Right Null -suggestSignature :: Bool -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] -suggestSignature isQuickFix mTmr mBindings Diagnostic {_message, _range = Range {..}} +-------------------------------------------------------------------------------- + +suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] +suggestSignature isQuickFix mGblSigs mTmr mBindings diag = + suggestGlobalSignature isQuickFix mGblSigs diag <> suggestLocalSignature isQuickFix mTmr mBindings diag + +suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, [TextEdit])] +suggestGlobalSignature isQuickFix mGblSigs Diagnostic {_message, _range} | _message - =~ ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text), + =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text), + Just (GlobalBindingTypeSigsResult sigs) <- mGblSigs, + Just sig <- find (\x -> sameThing (gbSrcSpan x) _range) sigs, + signature <- T.pack $ gbRendered sig, + title <- if isQuickFix then "add signature: " <> signature else signature, + Just action <- gblBindingTypeSigToEdit sig = + [(title, [action])] + | otherwise = [] + +suggestLocalSignature :: Bool -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] +suggestLocalSignature isQuickFix mTmr mBindings Diagnostic {_message, _range = _range@Range {..}} + | Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, [identifier]) <- + (T.unwords . T.words $ _message) + =~~ ("Polymorphic local binding with no type signature: (.*) ::" :: T.Text), Just bindings <- mBindings, - Just TcModuleResult {tmrTypechecked = TcGblEnv {tcg_type_env, tcg_rn_decls, tcg_rdr_env}} <- mTmr, localScope <- getFuzzyScope bindings _start _end, - Just group <- tcg_rn_decls, - Just name <- getFirstIdAtLine (succ $ _line _start) group, - Just (isPatSyn, ty) <- - (lookupTypeEnv tcg_type_env name >>= \x -> (isTyThingPatSyn x,) <$> safeTyThingType x) - <|> ((False,) <$> (find (\(x, _) -> x == name) localScope >>= snd)), + -- we can't use srcspan to lookup scoped bindings, because the error message reported by GHC includes the entire binding, instead of simply the name + Just (name, ty) <- find (\(x, _) -> printName x == T.unpack identifier) localScope >>= \(name, mTy) -> (name,) <$> mTy, + Just TcModuleResult {tmrTypechecked = TcGblEnv {tcg_rdr_env, tcg_sigs}} <- mTmr, + -- not a top-level thing, to avoid duplication + not $ name `elemNameSet` tcg_sigs, tyMsg <- showSDocForUser unsafeGlobalDynFlags (mkPrintUnqualified unsafeGlobalDynFlags tcg_rdr_env) $ pprSigmaType ty, - signature <- T.pack $ (if isPatSyn then "pattern " else "") <> printName name <> " :: " <> tyMsg, - startCharacter <- if "Polymorphic local" `T.isPrefixOf` T.dropWhile (not . isAlpha) _message then _character _start else 0, + signature <- T.pack $ printName name <> " :: " <> tyMsg, + startCharacter <- _character _start, startOfLine <- Position (_line _start) startCharacter, beforeLine <- Range startOfLine startOfLine, title <- if isQuickFix then "add signature: " <> signature else signature, @@ -117,16 +188,82 @@ suggestSignature isQuickFix mTmr mBindings Diagnostic {_message, _range = Range [(title, [action])] | otherwise = [] -isTyThingPatSyn :: TyThing -> Bool -isTyThingPatSyn (AConLike (PatSynCon _)) = True -isTyThingPatSyn _ = False - -getFirstIdAtLine :: Int -> HsGroup GhcRn -> Maybe Name -getFirstIdAtLine line = something (mkQ Nothing f) - where - f :: Located Name -> Maybe Name - f (L l name) - | RealSrcSpan s <- l, - srcSpanStartLine s == line = - Just name - | otherwise = Nothing +sameThing :: SrcSpan -> Range -> Bool +sameThing s1 s2 = (_start <$> srcSpanToRange s1) == (_start <$> Just s2) + +gblBindingTypeSigToEdit :: GlobalBindingTypeSig -> Maybe TextEdit +gblBindingTypeSigToEdit GlobalBindingTypeSig {..} + | Just Range {..} <- srcSpanToRange $ getSrcSpan gbName, + startOfLine <- Position (_line _start) 0, + beforeLine <- Range startOfLine startOfLine = + Just $ TextEdit beforeLine $ T.pack gbRendered <> "\n" + | otherwise = Nothing + +data Mode = Enabled | Exported | Diagnostics | Disabled + deriving (Generic, Eq, Ord, Show, Read, NFData) + +-------------------------------------------------------------------------------- + +showDocRdrEnv :: DynFlags -> GlobalRdrEnv -> SDoc -> String +showDocRdrEnv dflags rdrEnv = showSDocForUser dflags (mkPrintUnqualified dflags rdrEnv) + +data GetGlobalBindingTypeSigs = GetGlobalBindingTypeSigs + deriving (Generic, Show, Eq, Ord, Hashable, NFData, Binary) + +data GlobalBindingTypeSig = GlobalBindingTypeSig + { gbName :: Name, + gbRendered :: String, + gbExported :: Bool + } + +gbSrcSpan :: GlobalBindingTypeSig -> SrcSpan +gbSrcSpan GlobalBindingTypeSig {gbName} = getSrcSpan gbName + +newtype GlobalBindingTypeSigsResult = GlobalBindingTypeSigsResult [GlobalBindingTypeSig] + +instance Show GlobalBindingTypeSigsResult where + show _ = "" + +instance NFData GlobalBindingTypeSigsResult where + rnf = rwhnf + +type instance RuleResult GetGlobalBindingTypeSigs = GlobalBindingTypeSigsResult + +rules :: Rules () +rules = do + define $ \GetGlobalBindingTypeSigs nfp -> do + tmr <- use TypeCheck nfp + -- we need session here for tidying types + hsc <- use GhcSession nfp + result <- liftIO $ gblBindingType (hscEnv <$> hsc) (tmrTypechecked <$> tmr) + pure ([], result) + +parseCustomConfig :: A.Object -> Maybe Mode +parseCustomConfig = A.parseMaybe (\o -> read <$> o A..: "mode") + +gblBindingType :: Maybe HscEnv -> Maybe TcGblEnv -> IO (Maybe GlobalBindingTypeSigsResult) +gblBindingType (Just hsc) (Just gblEnv) = do + let exports = availsToNameSet $ tcg_exports gblEnv + sigs = tcg_sigs gblEnv + binds = collectHsBindsBinders $ tcg_binds gblEnv + patSyns = tcg_patsyns gblEnv + dflags = hsc_dflags hsc + rdrEnv = tcg_rdr_env gblEnv + showDoc = showDocRdrEnv dflags rdrEnv + hasSig :: (Monad m) => Name -> m a -> m (Maybe a) + hasSig name f = if name `elemNameSet` sigs then Just <$> f else pure Nothing + bindToSig id = do + let name = idName id + hasSig name $ do + env <- tcInitTidyEnv + let (_, ty) = tidyOpenType env (idType id) + pure $ GlobalBindingTypeSig name (printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports) + patToSig p = do + let name = patSynName p + -- we don't use pprPatSynType, since it always prints forall + ty = fromJust $ lookupTypeEnv (tcg_type_env gblEnv) name >>= safeTyThingType + hasSig name $ pure $ GlobalBindingTypeSig name ("pattern " <> printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports) + (_, maybe [] catMaybes -> bindings) <- initTcWithGbl hsc gblEnv (realSrcLocSpan $ mkRealSrcLoc "" 1 1) $ mapM bindToSig binds + patterns <- catMaybes <$> mapM patToSig patSyns + pure . Just . GlobalBindingTypeSigsResult $ bindings <> patterns +gblBindingType _ _ = pure Nothing From ab5c7c41d5045120b33c342109cb4c8c9fa6287f Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Thu, 4 Mar 2021 15:58:14 +0800 Subject: [PATCH 5/8] HLint --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index b5564320a3..2213c64348 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -15,6 +15,7 @@ where import Avail (availsToNameSet) import Control.DeepSeq (rwhnf) import Control.Monad (join) +import Control.Monad.Extra (whenMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.Aeson as A import Data.Aeson.Types (Value (..), toJSON) @@ -251,7 +252,7 @@ gblBindingType (Just hsc) (Just gblEnv) = do rdrEnv = tcg_rdr_env gblEnv showDoc = showDocRdrEnv dflags rdrEnv hasSig :: (Monad m) => Name -> m a -> m (Maybe a) - hasSig name f = if name `elemNameSet` sigs then Just <$> f else pure Nothing + hasSig name f = whenMaybe (name `elemNameSet` sigs) f bindToSig id = do let name = idName id hasSig name $ do From 070215f0e1aa5911360feeab1700b04153f1ca7c Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Thu, 4 Mar 2021 18:25:49 +0800 Subject: [PATCH 6/8] Remove Disabled mode --- .../src/Development/IDE/Plugin/TypeLenses.hs | 36 +++++++++---------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 2213c64348..d35f4b6202 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -99,7 +99,7 @@ codeLensProvider :: CodeLensParams -> LSP.LspM Config (Either ResponseError (List CodeLens)) codeLensProvider ideState pId CodeLensParams {_textDocument = TextDocumentIdentifier uri} = do - (fromMaybe Enabled . join -> mode) <- fmap (parseCustomConfig . plcConfig) <$> getPluginConfig pId + (fromMaybe Always . join -> mode) <- fmap (parseCustomConfig . plcConfig) <$> getPluginConfig pId fmap (Right . List) $ case uriToFilePath' uri of Just (toNormalizedFilePath' -> filePath) -> liftIO $ do tmr <- runAction "codeLens.TypeCheck" ideState (use TypeCheck filePath) @@ -116,27 +116,21 @@ codeLensProvider ideState pId CodeLensParams {_textDocument = TextDocumentIdenti let wedit = toWorkSpaceEdit [tedit] pure $ generateLens pId range (T.pack gbRendered) wedit gblSigs' = maybe [] (\(GlobalBindingTypeSigsResult x) -> x) gblSigs - - case mode of - Enabled -> - pure (catMaybes $ generateLensForGlobal <$> gblSigs') - <> sequence + generateLensFromDiags f = + sequence [ pure $ generateLens pId _range title edit | (dFile, _, dDiag@Diagnostic {_range = _range}) <- diag ++ hDiag, dFile == filePath, - (title, tedit) <- suggestLocalSignature False tmr bindings dDiag, + (title, tedit) <- f dDiag, let edit = toWorkSpaceEdit tedit ] + + case mode of + Always -> + pure (catMaybes $ generateLensForGlobal <$> gblSigs') + <> generateLensFromDiags (suggestLocalSignature False tmr bindings) Exported -> pure $ catMaybes $ generateLensForGlobal <$> filter gbExported gblSigs' - Diagnostics -> do - sequence - [ pure $ generateLens pId _range title edit - | (dFile, _, dDiag@Diagnostic {_range = _range}) <- diag ++ hDiag, - dFile == filePath, - (title, tedit) <- suggestSignature False gblSigs tmr bindings dDiag, - let edit = toWorkSpaceEdit tedit - ] - Disabled -> pure [] + Diagnostics -> generateLensFromDiags $ suggestSignature False gblSigs tmr bindings Nothing -> pure [] generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens @@ -200,8 +194,14 @@ gblBindingTypeSigToEdit GlobalBindingTypeSig {..} Just $ TextEdit beforeLine $ T.pack gbRendered <> "\n" | otherwise = Nothing -data Mode = Enabled | Exported | Diagnostics | Disabled - deriving (Generic, Eq, Ord, Show, Read, NFData) +data Mode + = -- | always displays type lenses of global bindings, no matter what GHC flags are set + Always + | -- | similar to 'Always', but only displays for exported global bindings + Exported + | -- | follows error messages produced by GHC + Diagnostics + deriving (Eq, Ord, Show, Read, Enum) -------------------------------------------------------------------------------- From 35790eee746badb89bcd0dcf475d401dd2907faa Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Thu, 4 Mar 2021 21:43:54 +0800 Subject: [PATCH 7/8] Update tests --- .../src/Development/IDE/Plugin/TypeLenses.hs | 2 +- ghcide/test/exe/Main.hs | 100 ++++++++++-------- 2 files changed, 54 insertions(+), 48 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index d35f4b6202..c635c95992 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -128,7 +128,7 @@ codeLensProvider ideState pId CodeLensParams {_textDocument = TextDocumentIdenti case mode of Always -> pure (catMaybes $ generateLensForGlobal <$> gblSigs') - <> generateLensFromDiags (suggestLocalSignature False tmr bindings) + <> generateLensFromDiags (suggestLocalSignature False tmr bindings) -- we still need diagnostics for local bindings Exported -> pure $ catMaybes $ generateLensForGlobal <$> filter gbExported gblSigs' Diagnostics -> generateLensFromDiags $ suggestSignature False gblSigs tmr bindings Nothing -> pure [] diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index d18ffa6079..7ac8b396e3 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -3154,54 +3154,60 @@ removeExportTests = testGroup "remove export actions" template = exportTemplate Nothing addSigLensesTests :: TestTree -addSigLensesTests = let - missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}" - notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}" - moduleH = T.unlines - [ - "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators #-}" - , "module Sigs where" - , "import qualified Data.Complex as C" - , "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)" - ] - other = T.unlines ["f :: Integer -> Integer", "f x = 3"] - before withMissing def - = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other] - after' withMissing def sig - = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, sig, def, other] - - sigSession withMissing def sig = testSession (T.unpack def) $ do - let originalCode = before withMissing def - let expectedCode = after' withMissing def sig - doc <- createDoc "Sigs.hs" "haskell" originalCode - [CodeLens {_command = Just c}] <- getCodeLenses doc - executeCommand c - modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc) - liftIO $ expectedCode @=? modifiedCode - in - testGroup "add signature" - [ testGroup title - [ sigSession enableWarnings "abc = True" "abc :: Bool" - , sigSession enableWarnings "foo a b = a + b" "foo :: Num a => a -> a -> a" - , sigSession enableWarnings "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String" - , sigSession enableWarnings "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool" - , sigSession enableWarnings "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a" - , sigSession enableWarnings "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2" - , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a" - , sigSession enableWarnings "qualifiedSigTest= C.realPart" "qualifiedSigTest :: C.Complex a -> a" - , sigSession enableWarnings "head = 233" "head :: Integer" - , sigSession enableWarnings "rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")" - "rank2Test :: (forall a. a -> a) -> (Int, [Char])" - , sigSession enableWarnings "symbolKindTest = Proxy @\"qwq\"" "symbolKindTest :: Proxy \"qwq\"" - , sigSession enableWarnings "promotedKindTest = Proxy @Nothing" "promotedKindTest :: Proxy 'Nothing" - , sigSession enableWarnings "typeOperatorTest = Refl" "typeOperatorTest :: a :~: a" - , sigSession enableWarnings "notInScopeTest = mkCharType" "notInScopeTest :: String -> Data.Data.DataType" - ] - | (title, enableWarnings) <- - [("with warnings enabled", True) - ,("with warnings disabled", False) +addSigLensesTests = + let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" + moduleH exported = + T.unlines + [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators #-}" + , "module Sigs(" <> exported <> ") where" + , "import qualified Data.Complex as C" + , "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)" + ] + before enableGHCWarnings exported (def, _) others = + T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others + after' enableGHCWarnings exported (def, sig) others = + T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others + createConfig mode = A.object ["haskell" A..= A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]] + sigSession testName enableGHCWarnings mode exported def others = testSession testName $ do + let originalCode = before enableGHCWarnings exported def others + let expectedCode = after' enableGHCWarnings exported def others + sendNotification SWorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode + doc <- createDoc "Sigs.hs" "haskell" originalCode + waitForProgressDone + codeLenses <- getCodeLenses doc + if not $ null $ snd def + then do + liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses + executeCommand $ fromJust $ head codeLenses ^. L.command + modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc) + liftIO $ expectedCode @=? modifiedCode + else liftIO $ null codeLenses @? "Expected no code lens, but got: " <> show codeLenses + cases = + [ ("abc = True", "abc :: Bool") + , ("foo a b = a + b", "foo :: Num a => a -> a -> a") + , ("bar a b = show $ a + b", "bar :: (Show a, Num a) => a -> a -> String") + , ("(!!!) a b = a > b", "(!!!) :: Ord a => a -> a -> Bool") + , ("a >>>> b = a + b", "(>>>>) :: Num a => a -> a -> a") + , ("a `haha` b = a b", "haha :: (t1 -> t2) -> t1 -> t2") + , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a") + , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a") + , ("head = 233", "head :: Integer") + , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, [Char])") + , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"") + , ("promotedKindTest = Proxy @Nothing", "promotedKindTest :: Proxy 'Nothing") + , ("typeOperatorTest = Refl", "typeOperatorTest :: a :~: a") + , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType") + ] + in testGroup + "add signature" + [ testGroup "signatures are correct" [sigSession (T.unpack def) False "Always" "" (def, Just sig) [] | (def, sig) <- cases] + , sigSession "exported mode works" False "Exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) + , testGroup + "diagnostics mode works" + [ sigSession "with GHC warnings" True "Diagnostics" "" (second Just $ head cases) [] + , sigSession "without GHC warnings" False "Diagnostics" "" (second (const Nothing) $ head cases) [] + ] ] - ] linkToLocation :: [LocationLink] -> [Location] linkToLocation = map (\LocationLink{_targetUri,_targetRange} -> Location _targetUri _targetRange) From 83bebc4c7c54d76457d89b5e0e053e3d79dcec8b Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Fri, 5 Mar 2021 11:02:28 +0800 Subject: [PATCH 8/8] Add FromJSON instance for mode --- .../src/Development/IDE/Plugin/TypeLenses.hs | 107 ++++++++++-------- ghcide/test/exe/Main.hs | 8 +- 2 files changed, 61 insertions(+), 54 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index c635c95992..40bd1390bb 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -2,15 +2,14 @@ {-# LANGUAGE TypeFamilies #-} -- | An HLS plugin to provide code lenses for type signatures -module Development.IDE.Plugin.TypeLenses - ( descriptor, - suggestSignature, - typeLensCommandId, - GlobalBindingTypeSig (..), - GetGlobalBindingTypeSigs (..), - GlobalBindingTypeSigsResult (..), - ) -where +module Development.IDE.Plugin.TypeLenses ( + descriptor, + suggestSignature, + typeLensCommandId, + GlobalBindingTypeSig (..), + GetGlobalBindingTypeSigs (..), + GlobalBindingTypeSigsResult (..), +) where import Avail (availsToNameSet) import Control.DeepSeq (rwhnf) @@ -88,9 +87,9 @@ typeLensCommandId = "typesignature.add" descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider, - pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler], - pluginRules = rules + { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider + , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] + , pluginRules = rules } codeLensProvider :: @@ -98,7 +97,7 @@ codeLensProvider :: PluginId -> CodeLensParams -> LSP.LspM Config (Either ResponseError (List CodeLens)) -codeLensProvider ideState pId CodeLensParams {_textDocument = TextDocumentIdentifier uri} = do +codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do (fromMaybe Always . join -> mode) <- fmap (parseCustomConfig . plcConfig) <$> getPluginConfig pId fmap (Right . List) $ case uriToFilePath' uri of Just (toNormalizedFilePath' -> filePath) -> liftIO $ do @@ -110,7 +109,7 @@ codeLensProvider ideState pId CodeLensParams {_textDocument = TextDocumentIdenti hDiag <- getHiddenDiagnostics ideState let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing - generateLensForGlobal sig@GlobalBindingTypeSig {..} = do + generateLensForGlobal sig@GlobalBindingTypeSig{..} = do range <- srcSpanToRange $ gbSrcSpan sig tedit <- gblBindingTypeSigToEdit sig let wedit = toWorkSpaceEdit [tedit] @@ -119,10 +118,10 @@ codeLensProvider ideState pId CodeLensParams {_textDocument = TextDocumentIdenti generateLensFromDiags f = sequence [ pure $ generateLens pId _range title edit - | (dFile, _, dDiag@Diagnostic {_range = _range}) <- diag ++ hDiag, - dFile == filePath, - (title, tedit) <- f dDiag, - let edit = toWorkSpaceEdit tedit + | (dFile, _, dDiag@Diagnostic{_range = _range}) <- diag ++ hDiag + , dFile == filePath + , (title, tedit) <- f dDiag + , let edit = toWorkSpaceEdit tedit ] case mode of @@ -150,36 +149,36 @@ suggestSignature isQuickFix mGblSigs mTmr mBindings diag = suggestGlobalSignature isQuickFix mGblSigs diag <> suggestLocalSignature isQuickFix mTmr mBindings diag suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, [TextEdit])] -suggestGlobalSignature isQuickFix mGblSigs Diagnostic {_message, _range} +suggestGlobalSignature isQuickFix mGblSigs Diagnostic{_message, _range} | _message - =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text), - Just (GlobalBindingTypeSigsResult sigs) <- mGblSigs, - Just sig <- find (\x -> sameThing (gbSrcSpan x) _range) sigs, - signature <- T.pack $ gbRendered sig, - title <- if isQuickFix then "add signature: " <> signature else signature, - Just action <- gblBindingTypeSigToEdit sig = + =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text) + , Just (GlobalBindingTypeSigsResult sigs) <- mGblSigs + , Just sig <- find (\x -> sameThing (gbSrcSpan x) _range) sigs + , signature <- T.pack $ gbRendered sig + , title <- if isQuickFix then "add signature: " <> signature else signature + , Just action <- gblBindingTypeSigToEdit sig = [(title, [action])] | otherwise = [] suggestLocalSignature :: Bool -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] -suggestLocalSignature isQuickFix mTmr mBindings Diagnostic {_message, _range = _range@Range {..}} +suggestLocalSignature isQuickFix mTmr mBindings Diagnostic{_message, _range = _range@Range{..}} | Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, [identifier]) <- (T.unwords . T.words $ _message) - =~~ ("Polymorphic local binding with no type signature: (.*) ::" :: T.Text), - Just bindings <- mBindings, - localScope <- getFuzzyScope bindings _start _end, - -- we can't use srcspan to lookup scoped bindings, because the error message reported by GHC includes the entire binding, instead of simply the name - Just (name, ty) <- find (\(x, _) -> printName x == T.unpack identifier) localScope >>= \(name, mTy) -> (name,) <$> mTy, - Just TcModuleResult {tmrTypechecked = TcGblEnv {tcg_rdr_env, tcg_sigs}} <- mTmr, - -- not a top-level thing, to avoid duplication - not $ name `elemNameSet` tcg_sigs, - tyMsg <- showSDocForUser unsafeGlobalDynFlags (mkPrintUnqualified unsafeGlobalDynFlags tcg_rdr_env) $ pprSigmaType ty, - signature <- T.pack $ printName name <> " :: " <> tyMsg, - startCharacter <- _character _start, - 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 " " = + =~~ ("Polymorphic local binding with no type signature: (.*) ::" :: T.Text) + , Just bindings <- mBindings + , localScope <- getFuzzyScope bindings _start _end + , -- we can't use srcspan to lookup scoped bindings, because the error message reported by GHC includes the entire binding, instead of simply the name + Just (name, ty) <- find (\(x, _) -> printName x == T.unpack identifier) localScope >>= \(name, mTy) -> (name,) <$> mTy + , Just TcModuleResult{tmrTypechecked = TcGblEnv{tcg_rdr_env, tcg_sigs}} <- mTmr + , -- not a top-level thing, to avoid duplication + not $ name `elemNameSet` tcg_sigs + , tyMsg <- showSDocForUser unsafeGlobalDynFlags (mkPrintUnqualified unsafeGlobalDynFlags tcg_rdr_env) $ pprSigmaType ty + , signature <- T.pack $ printName name <> " :: " <> tyMsg + , startCharacter <- _character _start + , 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 " " = [(title, [action])] | otherwise = [] @@ -187,10 +186,10 @@ sameThing :: SrcSpan -> Range -> Bool sameThing s1 s2 = (_start <$> srcSpanToRange s1) == (_start <$> Just s2) gblBindingTypeSigToEdit :: GlobalBindingTypeSig -> Maybe TextEdit -gblBindingTypeSigToEdit GlobalBindingTypeSig {..} - | Just Range {..} <- srcSpanToRange $ getSrcSpan gbName, - startOfLine <- Position (_line _start) 0, - beforeLine <- Range startOfLine startOfLine = +gblBindingTypeSigToEdit GlobalBindingTypeSig{..} + | Just Range{..} <- srcSpanToRange $ getSrcSpan gbName + , startOfLine <- Position (_line _start) 0 + , beforeLine <- Range startOfLine startOfLine = Just $ TextEdit beforeLine $ T.pack gbRendered <> "\n" | otherwise = Nothing @@ -203,6 +202,14 @@ data Mode Diagnostics deriving (Eq, Ord, Show, Read, Enum) +instance A.FromJSON Mode where + parseJSON = A.withText "Mode" $ \s -> + case T.toLower s of + "always" -> pure Always + "exported" -> pure Exported + "diagnostics" -> pure Diagnostics + _ -> A.unexpected (A.String s) + -------------------------------------------------------------------------------- showDocRdrEnv :: DynFlags -> GlobalRdrEnv -> SDoc -> String @@ -212,13 +219,13 @@ data GetGlobalBindingTypeSigs = GetGlobalBindingTypeSigs deriving (Generic, Show, Eq, Ord, Hashable, NFData, Binary) data GlobalBindingTypeSig = GlobalBindingTypeSig - { gbName :: Name, - gbRendered :: String, - gbExported :: Bool + { gbName :: Name + , gbRendered :: String + , gbExported :: Bool } gbSrcSpan :: GlobalBindingTypeSig -> SrcSpan -gbSrcSpan GlobalBindingTypeSig {gbName} = getSrcSpan gbName +gbSrcSpan GlobalBindingTypeSig{gbName} = getSrcSpan gbName newtype GlobalBindingTypeSigsResult = GlobalBindingTypeSigsResult [GlobalBindingTypeSig] @@ -240,7 +247,7 @@ rules = do pure ([], result) parseCustomConfig :: A.Object -> Maybe Mode -parseCustomConfig = A.parseMaybe (\o -> read <$> o A..: "mode") +parseCustomConfig = A.parseMaybe (A..: "mode") gblBindingType :: Maybe HscEnv -> Maybe TcGblEnv -> IO (Maybe GlobalBindingTypeSigsResult) gblBindingType (Just hsc) (Just gblEnv) = do diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 7ac8b396e3..ab5a2a4387 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -3200,12 +3200,12 @@ addSigLensesTests = ] in testGroup "add signature" - [ testGroup "signatures are correct" [sigSession (T.unpack def) False "Always" "" (def, Just sig) [] | (def, sig) <- cases] - , sigSession "exported mode works" False "Exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) + [ testGroup "signatures are correct" [sigSession (T.unpack def) False "always" "" (def, Just sig) [] | (def, sig) <- cases] + , sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) , testGroup "diagnostics mode works" - [ sigSession "with GHC warnings" True "Diagnostics" "" (second Just $ head cases) [] - , sigSession "without GHC warnings" False "Diagnostics" "" (second (const Nothing) $ head cases) [] + [ sigSession "with GHC warnings" True "diagnostics" "" (second Just $ head cases) [] + , sigSession "without GHC warnings" False "diagnostics" "" (second (const Nothing) $ head cases) [] ] ]