/
TypeLenses.hs
281 lines (251 loc) · 14.2 KB
/
TypeLenses.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedLabels #-}
{-# 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 Avail (availsToNameSet)
import Control.DeepSeq (rwhnf)
import Control.Monad.Extra (whenMaybe)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Aeson.Types (Value (..), toJSON)
import qualified Data.HashMap.Strict as Map
import Data.List (find)
import Data.Maybe (catMaybes, fromJust)
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))
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 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)
import Ide.Plugin.Properties
import Ide.PluginUtils (mkLspCommand,
usePropertyLsp)
import Ide.Types (CommandFunction,
CommandId (CommandId),
PluginCommand (PluginCommand),
PluginDescriptor (..),
PluginId,
defaultPluginDescriptor,
mkCustomConfig,
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 PatSyn (patSynName)
import TcEnv (tcInitTidyEnv)
import TcRnMonad (initTcWithGbl)
import TcRnTypes (TcGblEnv (..))
import TcType (pprSigmaType)
import Text.Regex.TDFA ((=~), (=~~))
typeLensCommandId :: T.Text
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
, pluginCustomConfig = mkCustomConfig properties
}
properties :: Properties '[ 'PropertyKey "mode" 'TEnum]
properties = emptyProperties
& defineEnumProperty #mode "Control how type lenses are shown"
[ ("always", "Always displays type lenses of global bindings")
, ("exported", "Only display type lenses of exported global bindings")
, ("diagnostics", "Follows error messages produced by GHC about missing signatures")
] "always"
codeLensProvider ::
IdeState ->
PluginId ->
CodeLensParams ->
LSP.LspM Config (Either ResponseError (List CodeLens))
codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do
mode <- readMode <$> usePropertyLsp #mode pId properties
fmap (Right . List) $ case uriToFilePath' uri of
Just (toNormalizedFilePath' -> filePath) -> liftIO $ do
tmr <- runAction "codeLens.TypeCheck" ideState (use TypeCheck filePath)
bindings <- runAction "codeLens.GetBindings" ideState (use GetBindings filePath)
gblSigs <- runAction "codeLens.GetGlobalBindingTypeSigs" ideState (use GetGlobalBindingTypeSigs filePath)
diag <- getDiagnostics ideState
hDiag <- getHiddenDiagnostics ideState
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
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
]
case mode of
Always ->
pure (catMaybes $ generateLensForGlobal <$> gblSigs')
<> 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 []
generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens
generateLens pId _range title edit =
let cId = mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit])
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 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|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
, 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 = []
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
= -- | 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)
--------------------------------------------------------------------------------
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 _ = "<GetTypeResult>"
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)
readMode :: T.Text -> Mode
readMode = \case
"always" -> Always
"exported" -> Exported
"diagnostics" -> Diagnostics
-- actually it never happens because of 'usePropertyLsp'
_ -> error "failed to parse type lenses 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 = whenMaybe (name `elemNameSet` sigs) f
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 "<dummy>" 1 1) $ mapM bindToSig binds
patterns <- catMaybes <$> mapM patToSig patSyns
pure . Just . GlobalBindingTypeSigsResult $ bindings <> patterns
gblBindingType _ _ = pure Nothing