1{-# LANGUAGE DeriveAnyClass   #-}
2{-# LANGUAGE OverloadedLabels #-}
3{-# LANGUAGE TypeFamilies     #-}
4
5-- | An HLS plugin to provide code lenses for type signatures
6module Development.IDE.Plugin.TypeLenses (
7  descriptor,
8  suggestSignature,
9  typeLensCommandId,
10  GlobalBindingTypeSig (..),
11  GetGlobalBindingTypeSigs (..),
12  GlobalBindingTypeSigsResult (..),
13) where
14
15import           Avail                               (availsToNameSet)
16import           Control.DeepSeq                     (rwhnf)
17import           Control.Monad                       (mzero)
18import           Control.Monad.Extra                 (whenMaybe)
19import           Control.Monad.IO.Class              (MonadIO (liftIO))
20import           Data.Aeson.Types                    (Value (..), toJSON)
21import qualified Data.Aeson.Types                    as A
22import qualified Data.HashMap.Strict                 as Map
23import           Data.List                           (find)
24import           Data.Maybe                          (catMaybes)
25import qualified Data.Text                           as T
26import           Development.IDE                     (GhcSession (..),
27                                                      HscEnvEq (hscEnv),
28                                                      RuleResult, Rules, define,
29                                                      srcSpanToRange)
30import           Development.IDE.Core.Compile        (TcModuleResult (..))
31import           Development.IDE.Core.RuleTypes      (GetBindings (GetBindings),
32                                                      TypeCheck (TypeCheck))
33import           Development.IDE.Core.Rules          (IdeState, runAction)
34import           Development.IDE.Core.Service        (getDiagnostics)
35import           Development.IDE.Core.Shake          (getHiddenDiagnostics, use)
36import           Development.IDE.GHC.Compat
37import           Development.IDE.GHC.Util            (printName)
38import           Development.IDE.Graph.Classes
39import           Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope)
40import           Development.IDE.Types.Location      (Position (Position, _character, _line),
41                                                      Range (Range, _end, _start),
42                                                      toNormalizedFilePath',
43                                                      uriToFilePath')
44import           GHC.Generics                        (Generic)
45import           GhcPlugins                          (GlobalRdrEnv,
46                                                      HscEnv (hsc_dflags), SDoc,
47                                                      elemNameSet, getSrcSpan,
48                                                      idName, mkRealSrcLoc,
49                                                      realSrcLocSpan,
50                                                      tidyOpenType)
51import           HscTypes                            (mkPrintUnqualified)
52import           Ide.Plugin.Config                   (Config)
53import           Ide.Plugin.Properties
54import           Ide.PluginUtils                     (mkLspCommand,
55                                                      usePropertyLsp)
56import           Ide.Types                           (CommandFunction,
57                                                      CommandId (CommandId),
58                                                      PluginCommand (PluginCommand),
59                                                      PluginDescriptor (..),
60                                                      PluginId,
61                                                      configCustomConfig,
62                                                      defaultConfigDescriptor,
63                                                      defaultPluginDescriptor,
64                                                      mkCustomConfig,
65                                                      mkPluginHandler)
66import qualified Language.LSP.Server                 as LSP
67import           Language.LSP.Types                  (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),
68                                                      CodeLens (CodeLens),
69                                                      CodeLensParams (CodeLensParams, _textDocument),
70                                                      Diagnostic (..),
71                                                      List (..), ResponseError,
72                                                      SMethod (..),
73                                                      TextDocumentIdentifier (TextDocumentIdentifier),
74                                                      TextEdit (TextEdit),
75                                                      WorkspaceEdit (WorkspaceEdit))
76import           Outputable                          (showSDocForUser)
77import           PatSyn                              (PatSyn, mkPatSyn,
78                                                      patSynBuilder,
79                                                      patSynFieldLabels,
80                                                      patSynIsInfix,
81                                                      patSynMatcher, patSynName,
82                                                      patSynSig, pprPatSynType)
83import           TcEnv                               (tcInitTidyEnv)
84import           TcRnMonad                           (initTcWithGbl)
85import           TcRnTypes                           (TcGblEnv (..))
86import           Text.Regex.TDFA                     ((=~), (=~~))
87
88typeLensCommandId :: T.Text
89typeLensCommandId = "typesignature.add"
90
91descriptor :: PluginId -> PluginDescriptor IdeState
92descriptor plId =
93  (defaultPluginDescriptor plId)
94    { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider
95    , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler]
96    , pluginRules = rules
97    , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}
98    }
99
100properties :: Properties '[ 'PropertyKey "mode" ('TEnum Mode)]
101properties = emptyProperties
102  & defineEnumProperty #mode "Control how type lenses are shown"
103    [ (Always, "Always displays type lenses of global bindings")
104    , (Exported, "Only display type lenses of exported global bindings")
105    , (Diagnostics, "Follows error messages produced by GHC about missing signatures")
106    ] Always
107
108codeLensProvider ::
109  IdeState ->
110  PluginId ->
111  CodeLensParams ->
112  LSP.LspM Config (Either ResponseError (List CodeLens))
113codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do
114  mode <- usePropertyLsp #mode pId properties
115  fmap (Right . List) $ case uriToFilePath' uri of
116    Just (toNormalizedFilePath' -> filePath) -> liftIO $ do
117      tmr <- runAction "codeLens.TypeCheck" ideState (use TypeCheck filePath)
118      bindings <- runAction "codeLens.GetBindings" ideState (use GetBindings filePath)
119      gblSigs <- runAction "codeLens.GetGlobalBindingTypeSigs" ideState (use GetGlobalBindingTypeSigs filePath)
120
121      diag <- getDiagnostics ideState
122      hDiag <- getHiddenDiagnostics ideState
123
124      let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing
125          generateLensForGlobal sig@GlobalBindingTypeSig{..} = do
126            range <- srcSpanToRange $ gbSrcSpan sig
127            tedit <- gblBindingTypeSigToEdit sig
128            let wedit = toWorkSpaceEdit [tedit]
129            pure $ generateLens pId range (T.pack gbRendered) wedit
130          gblSigs' = maybe [] (\(GlobalBindingTypeSigsResult x) -> x) gblSigs
131          generateLensFromDiags f =
132            sequence
133              [ pure $ generateLens pId _range title edit
134              | (dFile, _, dDiag@Diagnostic{_range = _range}) <- diag ++ hDiag
135              , dFile == filePath
136              , (title, tedit) <- f dDiag
137              , let edit = toWorkSpaceEdit tedit
138              ]
139
140      case mode of
141        Always ->
142          pure (catMaybes $ generateLensForGlobal <$> gblSigs')
143            <> generateLensFromDiags (suggestLocalSignature False tmr bindings) -- we still need diagnostics for local bindings
144        Exported -> pure $ catMaybes $ generateLensForGlobal <$> filter gbExported gblSigs'
145        Diagnostics -> generateLensFromDiags $ suggestSignature False gblSigs tmr bindings
146    Nothing -> pure []
147
148generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens
149generateLens pId _range title edit =
150  let cId = mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit])
151   in CodeLens _range (Just cId) Nothing
152
153commandHandler :: CommandFunction IdeState WorkspaceEdit
154commandHandler _ideState wedit = do
155  _ <- LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())
156  return $ Right Null
157
158--------------------------------------------------------------------------------
159
160suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])]
161suggestSignature isQuickFix mGblSigs mTmr mBindings diag =
162  suggestGlobalSignature isQuickFix mGblSigs diag <> suggestLocalSignature isQuickFix mTmr mBindings diag
163
164suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, [TextEdit])]
165suggestGlobalSignature isQuickFix mGblSigs Diagnostic{_message, _range}
166  | _message
167      =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text)
168    , Just (GlobalBindingTypeSigsResult sigs) <- mGblSigs
169    , Just sig <- find (\x -> sameThing (gbSrcSpan x) _range) sigs
170    , signature <- T.pack $ gbRendered sig
171    , title <- if isQuickFix then "add signature: " <> signature else signature
172    , Just action <- gblBindingTypeSigToEdit sig =
173    [(title, [action])]
174  | otherwise = []
175
176suggestLocalSignature :: Bool -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])]
177suggestLocalSignature isQuickFix mTmr mBindings Diagnostic{_message, _range = _range@Range{..}}
178  | Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, [identifier]) <-
179      (T.unwords . T.words $ _message)
180        =~~ ("Polymorphic local binding with no type signature: (.*) ::" :: T.Text)
181    , Just bindings <- mBindings
182    , localScope <- getFuzzyScope bindings _start _end
183    , -- 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
184      Just (name, ty) <- find (\(x, _) -> printName x == T.unpack identifier) localScope >>= \(name, mTy) -> (name,) <$> mTy
185    , Just TcModuleResult{tmrTypechecked = TcGblEnv{tcg_rdr_env, tcg_sigs}} <- mTmr
186    , -- not a top-level thing, to avoid duplication
187      not $ name `elemNameSet` tcg_sigs
188    , tyMsg <- showSDocForUser unsafeGlobalDynFlags (mkPrintUnqualified unsafeGlobalDynFlags tcg_rdr_env) $ pprSigmaType ty
189    , signature <- T.pack $ printName name <> " :: " <> tyMsg
190    , startCharacter <- _character _start
191    , startOfLine <- Position (_line _start) startCharacter
192    , beforeLine <- Range startOfLine startOfLine
193    , title <- if isQuickFix then "add signature: " <> signature else signature
194    , action <- TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " " =
195    [(title, [action])]
196  | otherwise = []
197
198sameThing :: SrcSpan -> Range -> Bool
199sameThing s1 s2 = (_start <$> srcSpanToRange s1) == (_start <$> Just s2)
200
201gblBindingTypeSigToEdit :: GlobalBindingTypeSig -> Maybe TextEdit
202gblBindingTypeSigToEdit GlobalBindingTypeSig{..}
203  | Just Range{..} <- srcSpanToRange $ getSrcSpan gbName
204    , startOfLine <- Position (_line _start) 0
205    , beforeLine <- Range startOfLine startOfLine =
206    Just $ TextEdit beforeLine $ T.pack gbRendered <> "\n"
207  | otherwise = Nothing
208
209data Mode
210  = -- | always displays type lenses of global bindings, no matter what GHC flags are set
211    Always
212  | -- | similar to 'Always', but only displays for exported global bindings
213    Exported
214  | -- |  follows error messages produced by GHC
215    Diagnostics
216  deriving (Eq, Ord, Show, Read, Enum)
217
218instance A.ToJSON Mode where
219  toJSON Always      = "always"
220  toJSON Exported    = "exported"
221  toJSON Diagnostics = "diagnostics"
222
223instance A.FromJSON Mode where
224  parseJSON = A.withText "Mode" $ \case
225    "always"      -> pure Always
226    "exported"    -> pure Exported
227    "diagnostics" -> pure Diagnostics
228    _             -> mzero
229
230--------------------------------------------------------------------------------
231
232showDocRdrEnv :: DynFlags -> GlobalRdrEnv -> SDoc -> String
233showDocRdrEnv dflags rdrEnv = showSDocForUser dflags (mkPrintUnqualified dflags rdrEnv)
234
235data GetGlobalBindingTypeSigs = GetGlobalBindingTypeSigs
236  deriving (Generic, Show, Eq, Ord, Hashable, NFData, Binary)
237
238data GlobalBindingTypeSig = GlobalBindingTypeSig
239  { gbName     :: Name
240  , gbRendered :: String
241  , gbExported :: Bool
242  }
243
244gbSrcSpan :: GlobalBindingTypeSig -> SrcSpan
245gbSrcSpan GlobalBindingTypeSig{gbName} = getSrcSpan gbName
246
247newtype GlobalBindingTypeSigsResult = GlobalBindingTypeSigsResult [GlobalBindingTypeSig]
248
249instance Show GlobalBindingTypeSigsResult where
250  show _ = "<GetTypeResult>"
251
252instance NFData GlobalBindingTypeSigsResult where
253  rnf = rwhnf
254
255type instance RuleResult GetGlobalBindingTypeSigs = GlobalBindingTypeSigsResult
256
257rules :: Rules ()
258rules = do
259  define $ \GetGlobalBindingTypeSigs nfp -> do
260    tmr <- use TypeCheck nfp
261    -- we need session here for tidying types
262    hsc <- use GhcSession nfp
263    result <- liftIO $ gblBindingType (hscEnv <$> hsc) (tmrTypechecked <$> tmr)
264    pure ([], result)
265
266gblBindingType :: Maybe HscEnv -> Maybe TcGblEnv -> IO (Maybe GlobalBindingTypeSigsResult)
267gblBindingType (Just hsc) (Just gblEnv) = do
268  let exports = availsToNameSet $ tcg_exports gblEnv
269      sigs = tcg_sigs gblEnv
270      binds = collectHsBindsBinders $ tcg_binds gblEnv
271      patSyns = tcg_patsyns gblEnv
272      dflags = hsc_dflags hsc
273      rdrEnv = tcg_rdr_env gblEnv
274      showDoc = showDocRdrEnv dflags rdrEnv
275      hasSig :: (Monad m) => Name -> m a -> m (Maybe a)
276      hasSig name f = whenMaybe (name `elemNameSet` sigs) f
277      bindToSig id = do
278        let name = idName id
279        hasSig name $ do
280          env <- tcInitTidyEnv
281          let (_, ty) = tidyOpenType env (idType id)
282          pure $ GlobalBindingTypeSig name (printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports)
283      patToSig p = do
284        let name = patSynName p
285        hasSig name $ pure $ GlobalBindingTypeSig name ("pattern " <> printName name <> " :: " <> showDoc (pprPatSynTypeWithoutForalls p)) (name `elemNameSet` exports)
286  (_, maybe [] catMaybes -> bindings) <- initTcWithGbl hsc gblEnv (realSrcLocSpan $ mkRealSrcLoc "<dummy>" 1 1) $ mapM bindToSig binds
287  patterns <- catMaybes <$> mapM patToSig patSyns
288  pure . Just . GlobalBindingTypeSigsResult $ bindings <> patterns
289gblBindingType _ _ = pure Nothing
290
291pprPatSynTypeWithoutForalls :: PatSyn -> SDoc
292pprPatSynTypeWithoutForalls p = pprPatSynType pWithoutTypeVariables
293  where
294    pWithoutTypeVariables = mkPatSyn name declared_infix ([], req_theta) ([], prov_theta) orig_args' orig_res_ty matcher builder field_labels
295    (_univ_tvs, req_theta, _ex_tvs, prov_theta, orig_args, orig_res_ty) = patSynSig p
296    name = patSynName p
297    declared_infix = patSynIsInfix p
298    matcher = patSynMatcher p
299    builder = patSynBuilder p
300    field_labels = patSynFieldLabels p
301    orig_args' = map scaledThing orig_args
302