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