Skip to content

Commit bc24187

Browse files
berbermanberberman
committed
Retrieve Type from typecheck result for type lenses
1 parent eff69a7 commit bc24187

File tree

3 files changed

+84
-62
lines changed

3 files changed

+84
-62
lines changed

‎ghcide/src/Development/IDE/Plugin/CodeAction.hs

Lines changed: 8 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -51,6 +51,7 @@ import Development.IDE.Plugin.CodeAction.ExactPrint
5151
import Development.IDE.Plugin.CodeAction.PositionIndexed
5252
import Development.IDE.Plugin.TypeLenses (suggestSignature)
5353
import Development.IDE.Spans.Common
54+
import Development.IDE.Spans.LocalBindings (Bindings)
5455
import Development.IDE.Types.Exports
5556
import Development.IDE.Types.HscEnvEq
5657
import Development.IDE.Types.Location
@@ -97,13 +98,14 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range Cod
9798
let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
9899
mbFile = toNormalizedFilePath' <$> uriToFilePath uri
99100
diag <- fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state
100-
(ideOptions, join -> parsedModule, join -> env, join -> annotatedPS, join -> tcM, join -> har) <- runAction "CodeAction" state $
101-
(,,,,,) <$> getIdeOptions
101+
(ideOptions, join -> parsedModule, join -> env, join -> annotatedPS, join -> tcM, join -> har, join -> bindings) <- runAction "CodeAction" state $
102+
(,,,,,,) <$> getIdeOptions
102103
<*> getParsedModule `traverse` mbFile
103104
<*> use GhcSession `traverse` mbFile
104105
<*> use GetAnnotatedParsedSource `traverse` mbFile
105106
<*> use TypeCheck `traverse` mbFile
106107
<*> use GetHieAst `traverse` mbFile
108+
<*> use GetBindings `traverse` mbFile
107109
-- This is quite expensive 0.6-0.7s on GHC
108110
pkgExports <- maybe mempty envPackageExports env
109111
localExports <- readVar (exportsMap $ shakeExtras state)
@@ -112,7 +114,7 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range Cod
112114
df = ms_hspp_opts . pm_mod_summary <$> parsedModule
113115
actions =
114116
[ mkCA title [x] edit
115-
| x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text df annotatedPS tcM har x
117+
| x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text df annotatedPS tcM har bindings x
116118
, let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
117119
]
118120
actions' = caRemoveRedundantImports parsedModule text diag xs uri
@@ -144,12 +146,13 @@ suggestAction
144146
-> Maybe (Annotated ParsedSource)
145147
-> Maybe TcModuleResult
146148
-> Maybe HieAstResult
149+
-> Maybe Bindings
147150
-> Diagnostic
148151
-> [(T.Text, [TextEdit])]
149-
suggestAction packageExports ideOptions parsedModule text df annSource tcM har diag =
152+
suggestAction packageExports ideOptions parsedModule text df annSource tcM har bindings diag =
150153
concat
151154
-- Order these suggestions by priority
152-
[ suggestSignature True diag
155+
[ suggestSignature True tcM bindings diag
153156
, rewrite df annSource $ \_ ps -> suggestExtendImport packageExports ps diag
154157
, rewrite df annSource $ \df ps ->
155158
suggestImportDisambiguation df text ps diag

‎ghcide/src/Development/IDE/Plugin/TypeLenses.hs

Lines changed: 73 additions & 53 deletions
Original file line numberDiff line numberDiff line change
@@ -6,36 +6,51 @@ module Development.IDE.Plugin.TypeLenses
66
)
77
where
88

9+
import Control.Applicative ((<|>))
910
import Control.Monad.IO.Class
10-
import Data.Aeson.Types (Value (..), toJSON)
11-
import qualified Data.HashMap.Strict as Map
12-
import qualified Data.Text as T
13-
import Development.IDE.Core.RuleTypes (TypeCheck (TypeCheck))
14-
import Development.IDE.Core.Rules (IdeState, runAction)
15-
import Development.IDE.Core.Service (getDiagnostics)
16-
import Development.IDE.Core.Shake (getHiddenDiagnostics, use)
17-
import Development.IDE.Types.Location (Position (Position, _character, _line),
18-
Range (Range, _end, _start),
19-
toNormalizedFilePath',
20-
uriToFilePath')
21-
import Ide.PluginUtils (mkLspCommand)
22-
import Ide.Types (CommandFunction,
23-
CommandId (CommandId),
24-
PluginCommand (PluginCommand),
25-
PluginDescriptor (..),
26-
PluginId,
27-
defaultPluginDescriptor,
28-
mkPluginHandler)
29-
import qualified Language.LSP.Server as LSP
30-
import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),
31-
CodeLens (CodeLens),
32-
CodeLensParams (CodeLensParams, _textDocument),
33-
Diagnostic (..), List (..),
34-
ResponseError, SMethod (..),
35-
TextDocumentIdentifier (TextDocumentIdentifier),
36-
TextEdit (TextEdit),
37-
WorkspaceEdit (WorkspaceEdit))
38-
import Text.Regex.TDFA ((=~))
11+
import Data.Aeson.Types (Value (..), toJSON)
12+
import Data.Generics (mkQ, something)
13+
import qualified Data.HashMap.Strict as Map
14+
import Data.List (find)
15+
import qualified Data.Text as T
16+
import Development.IDE.Core.Compile (TcModuleResult (..))
17+
import Development.IDE.Core.RuleTypes (GetBindings (GetBindings),
18+
TypeCheck (TypeCheck))
19+
import Development.IDE.Core.Rules (IdeState, runAction)
20+
import Development.IDE.Core.Service (getDiagnostics)
21+
import Development.IDE.Core.Shake (getHiddenDiagnostics, use)
22+
import Development.IDE.GHC.Compat
23+
import Development.IDE.GHC.Util (printName)
24+
import Development.IDE.Spans.Common (safeTyThingType)
25+
import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope)
26+
import Development.IDE.Types.Location (Position (Position, _character, _line),
27+
Range (Range, _end, _start),
28+
toNormalizedFilePath',
29+
uriToFilePath')
30+
import HscTypes (lookupTypeEnv,
31+
mkPrintUnqualified)
32+
import Ide.PluginUtils (mkLspCommand)
33+
import Ide.Types (CommandFunction,
34+
CommandId (CommandId),
35+
PluginCommand (PluginCommand),
36+
PluginDescriptor (..),
37+
PluginId,
38+
defaultPluginDescriptor,
39+
mkPluginHandler)
40+
import qualified Language.LSP.Server as LSP
41+
import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),
42+
CodeLens (CodeLens),
43+
CodeLensParams (CodeLensParams, _textDocument),
44+
Diagnostic (..),
45+
List (..), ResponseError,
46+
SMethod (..),
47+
TextDocumentIdentifier (TextDocumentIdentifier),
48+
TextEdit (TextEdit),
49+
WorkspaceEdit (WorkspaceEdit))
50+
import Outputable (showSDocForUser)
51+
import TcRnTypes (TcGblEnv (TcGblEnv, tcg_rdr_env, tcg_rn_decls, tcg_type_env))
52+
import TcType (pprSigmaType)
53+
import Text.Regex.TDFA ((=~))
3954

4055
typeLensCommandId :: T.Text
4156
typeLensCommandId = "typesignature.add"
@@ -55,14 +70,15 @@ codeLensProvider ::
5570
codeLensProvider ideState pId CodeLensParams {_textDocument = TextDocumentIdentifier uri} = do
5671
fmap (Right . List) $ case uriToFilePath' uri of
5772
Just (toNormalizedFilePath' -> filePath) -> liftIO $ do
58-
_ <- runAction "codeLens" ideState (use TypeCheck filePath)
73+
tmr <- runAction "codeLens.TypeCheck" ideState (use TypeCheck filePath)
74+
bindings <- runAction "bindings.GetBindings" ideState (use GetBindings filePath)
5975
diag <- getDiagnostics ideState
6076
hDiag <- getHiddenDiagnostics ideState
6177
sequence
6278
[ generateLens pId _range title edit
6379
| (dFile, _, dDiag@Diagnostic {_range = _range}) <- diag ++ hDiag,
6480
dFile == filePath,
65-
(title, tedit) <- suggestSignature False dDiag,
81+
(title, tedit) <- suggestSignature False tmr bindings dDiag,
6682
let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
6783
]
6884
Nothing -> pure []
@@ -77,33 +93,37 @@ commandHandler _ideState wedit = do
7793
_ <- LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())
7894
return $ Right Null
7995

80-
suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
81-
suggestSignature isQuickFix Diagnostic {_range = _range@Range {..}, ..}
96+
suggestSignature :: Bool -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])]
97+
suggestSignature isQuickFix mTmr mBindings Diagnostic {_message, _range = _range@Range {..}}
8298
| _message
83-
=~ ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text) =
84-
let signature =
85-
removeInitialForAll $
86-
T.takeWhile (\x -> x /= '*' && x /= '•') $
87-
T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
88-
startOfLine = Position (_line _start) startCharacter
89-
beforeLine = Range startOfLine startOfLine
90-
title = if isQuickFix then "add signature: " <> signature else signature
91-
action = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " "
92-
in [(title, [action])]
99+
=~ ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text),
100+
Just bindings <- mBindings,
101+
Just TcModuleResult {tmrTypechecked = TcGblEnv {tcg_type_env, tcg_rn_decls, tcg_rdr_env}} <- mTmr,
102+
localScope <- getFuzzyScope bindings _start _end,
103+
Just group <- tcg_rn_decls,
104+
Just name <- getFirstIdAtLine (succ $ _line _start) group,
105+
Just ty <- (lookupTypeEnv tcg_type_env name >>= safeTyThingType) <|> (find (\(x, _) -> x == name) localScope >>= snd),
106+
tyMsg <- showSDocForUser unsafeGlobalDynFlags (mkPrintUnqualified unsafeGlobalDynFlags tcg_rdr_env) $ pprSigmaType ty,
107+
signature <- T.pack $ printName name <> " :: " <> tyMsg,
108+
startOfLine <- Position (_line _start) startCharacter,
109+
beforeLine <- Range startOfLine startOfLine,
110+
title <- if isQuickFix then "add signature: " <> signature else signature,
111+
action <- TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " " =
112+
[(title, [action])]
113+
| otherwise = []
93114
where
94-
removeInitialForAll :: T.Text -> T.Text
95-
removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))
96-
| "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))
97-
| otherwise = nm <> ty
98115
startCharacter
99116
| "Polymorphic local binding" `T.isPrefixOf` _message =
100117
_character _start
101118
| otherwise =
102119
0
103-
suggestSignature _ _ = []
104120

105-
unifySpaces :: T.Text -> T.Text
106-
unifySpaces = T.unwords . T.words
107-
108-
filterNewlines :: T.Text -> T.Text
109-
filterNewlines = T.concat . T.lines
121+
getFirstIdAtLine :: Int -> HsGroup GhcRn -> Maybe Name
122+
getFirstIdAtLine line = something (mkQ Nothing f)
123+
where
124+
f :: Located Name -> Maybe Name
125+
f (L l name)
126+
| RealSrcSpan s <- l,
127+
srcSpanStartLine s == line =
128+
Just name
129+
| otherwise = Nothing

‎ghcide/src/Development/IDE/Spans/Common.hs

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -25,7 +25,6 @@ import qualified Data.Text as T
2525
import GHC.Generics
2626

2727
import ConLike
28-
import DataCon
2928
import DynFlags
3029
import GHC
3130
import NameEnv
@@ -66,9 +65,9 @@ safeTyThingType (ATyCon tycon) = Just (tyConKind tycon)
6665
safeTyThingType _ = Nothing
6766

6867
safeTyThingId :: TyThing -> Maybe Id
69-
safeTyThingId (AnId i) = Just i
70-
safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc
71-
safeTyThingId _ = Nothing
68+
safeTyThingId (AnId i) = Just i
69+
safeTyThingId (AConLike conLike) = conLikeWrapId_maybe conLike
70+
safeTyThingId _ = Nothing
7271

7372
-- Possible documentation for an element in the code
7473
data SpanDoc

0 commit comments

Comments
 (0)