|
| 1 | +{-# LANGUAGE AllowAmbiguousTypes #-} |
| 2 | +{-# LANGUAGE CPP #-} |
| 3 | +{-# LANGUAGE DeriveAnyClass #-} |
| 4 | +{-# LANGUAGE OverloadedStrings #-} |
| 5 | +{-# LANGUAGE RecordWildCards #-} |
| 6 | +{-# LANGUAGE TypeFamilies #-} |
| 7 | +module Ide.Plugin.Render ( |
| 8 | + descriptor |
| 9 | +) where |
| 10 | + |
| 11 | +import Development.IDE (IdeState, |
| 12 | + LinkableType (BCOLinkable), |
| 13 | + TcModuleResult (tmrTypechecked), |
| 14 | + defineEarlyCutoff, |
| 15 | + modifyDynFlags, |
| 16 | + srcSpanToRange, |
| 17 | + use_, |
| 18 | + GetParsedModule (GetParsedModule), |
| 19 | + RuleResult, |
| 20 | + Rules, |
| 21 | + VFSModified (VFSUnmodified), |
| 22 | + evalGhcEnv, |
| 23 | + runAction, |
| 24 | + useNoFile_, |
| 25 | + uses_) |
| 26 | +import Development.IDE.Core.PluginUtils (runActionE, |
| 27 | + uriToFilePathE, |
| 28 | + useWithStaleE) |
| 29 | +import Ide.Logger (Pretty (pretty), |
| 30 | + Priority (Debug), |
| 31 | + Recorder, |
| 32 | + WithPriority, |
| 33 | + cmapWithPrio, |
| 34 | + logWith) |
| 35 | +import Ide.Plugin.Error (PluginError) |
| 36 | +import Ide.Types (CommandFunction, |
| 37 | + CommandId, |
| 38 | + Config, |
| 39 | + ConfigDescriptor (configCustomConfig), |
| 40 | + HandlerM, |
| 41 | + PluginCommand (PluginCommand), |
| 42 | + PluginDescriptor (pluginCommands, pluginConfigDescriptor, pluginHandlers, pluginRules), |
| 43 | + PluginId, |
| 44 | + PluginMethodHandler, |
| 45 | + defaultConfigDescriptor, |
| 46 | + defaultPluginDescriptor, |
| 47 | + mkCustomConfig, |
| 48 | + mkLspCommand, |
| 49 | + mkPluginHandler, |
| 50 | + pluginWithIndefiniteProgress) |
| 51 | +import Language.LSP.Protocol.Lens (HasTextDocument (textDocument)) |
| 52 | +import Language.LSP.Protocol.Message (Method (Method_TextDocumentCodeLens), |
| 53 | + SMethod (SMethod_TextDocumentCodeLens)) |
| 54 | +import Language.LSP.Protocol.Types (CodeLens (CodeLens), |
| 55 | + Command, |
| 56 | + Null (Null), |
| 57 | + TextDocumentIdentifier (..), |
| 58 | + type (|?) (InL, InR)) |
| 59 | + |
| 60 | +import Control.Monad.Trans.Except (ExceptT (..), |
| 61 | + runExceptT) |
| 62 | +import Data.Function ((&)) |
| 63 | +import Development.IDE.Core.RuleTypes (GetLinkable (..), |
| 64 | + GetModSummary (..), |
| 65 | + GetModuleGraph (..), |
| 66 | + GhcSessionDeps (..), |
| 67 | + NeedsCompilation (..), |
| 68 | + TypeCheck (TypeCheck), |
| 69 | + encodeLinkableType, |
| 70 | + linkableHomeMod, |
| 71 | + msrModSummary) |
| 72 | +import Development.IDE.GHC.Compat.Core (DynFlags (canUseColor, useColor), |
| 73 | + GenLocated (..), |
| 74 | + GenModule (moduleName), |
| 75 | + GeneralFlag (Opt_DiagnosticsShowCaret, Opt_ImplicitImportQualified), |
| 76 | + Ghc, GhcMonad, |
| 77 | + GhcPs, |
| 78 | + HasOccName (occName), |
| 79 | + HasSrcSpan (..), |
| 80 | + HomeModInfo (hm_iface), |
| 81 | + HsDecl (SigD), |
| 82 | + HsModule (hsmodDecls), |
| 83 | + HscEnv, |
| 84 | + InteractiveImport (IIDecl), |
| 85 | + ModIface_ (mi_globals, mi_module), |
| 86 | + ModSummary (ms_hspp_opts), |
| 87 | + Name, |
| 88 | + Sig (TypeSig), |
| 89 | + SrcSpan, |
| 90 | + TcRnExprMode (TM_Default), |
| 91 | + forceGlobalRdrEnv, |
| 92 | + getContext, |
| 93 | + gopt_set, |
| 94 | + gopt_unset, |
| 95 | + ms_mod, |
| 96 | + occNameString, |
| 97 | + parseImportDecl, |
| 98 | + runDecls, |
| 99 | + setContext, |
| 100 | + tcg_rdr_env, |
| 101 | + unLoc, xopt_set, |
| 102 | + xopt_unset) |
| 103 | +import Development.IDE.GHC.Compat.Env (ghciBackend, |
| 104 | + setBackend) |
| 105 | +import Development.IDE.Types.Location |
| 106 | +import GHC (ParsedModule (pm_parsed_source), |
| 107 | + SrcSpanAnnA) |
| 108 | +--import GHC (unLoc, HsDecl (ValD), HsBindLR (..), GenLocated (L), HsExpr (HsVar), ParsedModule (pm_parsed_source), SrcSpanAnn' (SrcSpanAnn), GhcPs, SrcSpanAnnA, DynFlags (useColor, canUseColor), Target (Target), TargetId (TargetFile), load, LoadHowMuch (LoadAllTargets), guessTarget, Ghc) |
| 109 | +import Control.Exception.Base (bracket_) |
| 110 | +import Control.Exception.Safe (catchAny) |
| 111 | +import Control.Lens ((^.)) |
| 112 | +import Control.Monad (forM) |
| 113 | +import Control.Monad.IO.Class (liftIO) |
| 114 | +import Data.Aeson (FromJSON, ToJSON, |
| 115 | + toJSON) |
| 116 | +import qualified Data.ByteString as BS |
| 117 | +import Data.Foldable (traverse_) |
| 118 | +import Data.HashSet (HashSet) |
| 119 | +import qualified Data.HashSet as Set |
| 120 | +import Data.IORef (IORef, |
| 121 | + atomicModifyIORef', |
| 122 | + newIORef, |
| 123 | + readIORef) |
| 124 | +import Data.List (isPrefixOf) |
| 125 | +import Data.Maybe (mapMaybe) |
| 126 | +import qualified Data.Text as T |
| 127 | +import qualified Data.Text.IO as T |
| 128 | +import Development.IDE.Core.Compile (loadModulesHome) |
| 129 | +import Development.IDE.Core.FileStore (addIdeGlobal, |
| 130 | + setSomethingModified) |
| 131 | +import Development.IDE.Core.Rules (needsCompilationRule, |
| 132 | + transitiveModuleDeps) |
| 133 | +import Development.IDE.Core.Shake (IsIdeGlobal, |
| 134 | + RuleBody (RuleNoDiagnostics, RuleWithCustomNewnessCheck), |
| 135 | + getIdeGlobalAction, |
| 136 | + getIdeGlobalState) |
| 137 | +import qualified Development.IDE.Core.Shake as Shake |
| 138 | +import qualified Development.IDE.GHC.Compat as Compat |
| 139 | +import Development.IDE.GHC.Compat.Util (OverridingBool (Never)) |
| 140 | +import Development.IDE.Graph (alwaysRerun) |
| 141 | +import Development.IDE.Graph.Classes (Hashable, NFData) |
| 142 | +import Development.IDE.Import.DependencyInformation (transitiveDeps) |
| 143 | +import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) |
| 144 | +import Development.IDE.Types.Shake (toKey) |
| 145 | +import GHC.Driver.Ppr (showPprUnsafe) |
| 146 | +import GHC.Generics (Generic) |
| 147 | +import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) |
| 148 | +import GHC.Runtime.Eval (ExecOptions (..), |
| 149 | + execOptions, |
| 150 | + execStmt, |
| 151 | + exprType) |
| 152 | +import Ide.Plugin.Render.Config (RenderConfig (..), |
| 153 | + getRenderConfig, |
| 154 | + properties) |
| 155 | +import Language.LSP.Server (ProgressCancellable (Cancellable)) |
| 156 | +import UnliftIO (MonadIO) |
| 157 | + |
| 158 | +data RenderParams = RenderParams |
| 159 | + { paramValue :: String |
| 160 | + , paramAction :: String |
| 161 | + , paramModuleName :: !TextDocumentIdentifier |
| 162 | + } |
| 163 | + deriving (Eq, Show, Generic, FromJSON, ToJSON) |
| 164 | + |
| 165 | +instance Pretty RenderParams where |
| 166 | + pretty RenderParams {..} = |
| 167 | + "Render=" |
| 168 | + <> pretty paramModuleName |
| 169 | + <> " : " |
| 170 | + <> pretty paramAction |
| 171 | + <> " " |
| 172 | + <> pretty paramValue |
| 173 | + |
| 174 | +data Log |
| 175 | + = LogAvailableRenderActions [RenderParams] |
| 176 | + | LogRunningRenderAction RenderParams |
| 177 | + | LogShake Shake.Log |
| 178 | + |
| 179 | +instance Pretty Log where |
| 180 | + pretty (LogAvailableRenderActions actions) = "Render : Available Actions : " <> pretty actions |
| 181 | + pretty (LogRunningRenderAction action) = "Render : Running : " <> pretty action |
| 182 | + pretty (LogShake s) = "Render : Shake :" <> pretty s |
| 183 | + |
| 184 | +codeLensHandler :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCodeLens |
| 185 | +codeLensHandler recorder st plId params = do |
| 186 | + rangeCommands <- mkRangeCommands recorder st plId (params ^. textDocument) |
| 187 | + pure |
| 188 | + $ InL |
| 189 | + [ CodeLens range (Just command) Nothing |
| 190 | + | (range, command) <- rangeCommands |
| 191 | + ] |
| 192 | + |
| 193 | +mkRangeCommands :: Recorder (WithPriority Log) -> IdeState -> PluginId -> TextDocumentIdentifier -> ExceptT PluginError (HandlerM Config) [(Range, Command)] |
| 194 | +mkRangeCommands recorder st plId textDocument = |
| 195 | + let dbg = logWith recorder Debug |
| 196 | + in do |
| 197 | + let TextDocumentIdentifier uri = textDocument |
| 198 | + fp <- uriToFilePathE uri |
| 199 | + let nfp = toNormalizedFilePath' fp |
| 200 | + (mod, _positioning) <- runActionE "render.GetParsedModule" st $ useWithStaleE GetParsedModule nfp |
| 201 | + let topLevelDecls :: [GenLocated SrcSpanAnnA (HsDecl GhcPs)] |
| 202 | + topLevelDecls = mod |
| 203 | + & pm_parsed_source |
| 204 | + & unLoc |
| 205 | + & hsmodDecls |
| 206 | + |
| 207 | + let getFunBind'' :: HasSrcSpan a => GenLocated a (HsDecl GhcPs) -> [(SrcSpan, String)] |
| 208 | + getFunBind'' (L l (SigD _ (TypeSig _ [ids] _))) = [(getLoc l, occNameString . occName . unLoc $ ids)] |
| 209 | + getFunBind'' _ = [] |
| 210 | + |
| 211 | + let valueDecls = topLevelDecls >>= getFunBind'' |
| 212 | + |
| 213 | + viableCommands <- |
| 214 | + fmap (mconcat . mconcat) $ |
| 215 | + runInGhcEnv plId st fp $ \names _opts -> do |
| 216 | + forM valueDecls $ \(l, v) -> |
| 217 | + forM names $ \name -> do |
| 218 | + let n = occNameString . occName $ name |
| 219 | + (`catchAny` (const . pure $ [])) $ do |
| 220 | + t <- exprType TM_Default (n <> " " <> v) |
| 221 | + return [(l, |
| 222 | + RenderParams |
| 223 | + { paramAction = n |
| 224 | + , paramValue = v |
| 225 | + , paramModuleName = textDocument} |
| 226 | + ) | showPprUnsafe t == "IO ()"] |
| 227 | + |
| 228 | + let makeCommand (l, params@RenderParams {..}) = |
| 229 | + let args = Just . pure . toJSON $ params |
| 230 | + cmdText = "Render=" <> T.pack paramAction <> " " <> T.pack paramValue |
| 231 | + in (, mkLspCommand plId renderCommandName cmdText args) <$> srcSpanToRange l |
| 232 | + let cmds = mapMaybe makeCommand viableCommands |
| 233 | + |
| 234 | + dbg . LogAvailableRenderActions $ (snd <$> viableCommands) |
| 235 | + pure cmds |
| 236 | + |
| 237 | +renderCommandName :: CommandId |
| 238 | +renderCommandName = "Render" |
| 239 | + |
| 240 | +initialiseSessionForEval :: IdeState -> NormalizedFilePath -> IO HscEnv |
| 241 | +initialiseSessionForEval st nfp = do |
| 242 | + (ms, env1) <- runAction "runRenderCmd" st $ do |
| 243 | + |
| 244 | + ms <- msrModSummary <$> use_ GetModSummary nfp |
| 245 | + deps_hsc <- hscEnv <$> use_ GhcSessionDeps nfp |
| 246 | + |
| 247 | + linkables_needed <- transitiveDeps <$> useNoFile_ GetModuleGraph <*> pure nfp |
| 248 | + linkables <- uses_ GetLinkable (nfp : maybe [] transitiveModuleDeps linkables_needed) |
| 249 | + -- We unset the global rdr env in mi_globals when we generate interfaces |
| 250 | + -- See Note [Clearing mi_globals after generating an iface] |
| 251 | + -- However, the eval plugin (setContext specifically) requires the rdr_env |
| 252 | + -- for the current module - so get it from the Typechecked Module and add |
| 253 | + -- it back to the iface for the current module. |
| 254 | + tm <- tmrTypechecked <$> use_ TypeCheck nfp |
| 255 | + let rdr_env = tcg_rdr_env tm |
| 256 | + let linkable_hsc = loadModulesHome (map (addRdrEnv . linkableHomeMod) linkables) deps_hsc |
| 257 | + addRdrEnv hmi |
| 258 | + | iface <- hm_iface hmi |
| 259 | + , ms_mod ms == mi_module iface |
| 260 | +#if MIN_VERSION_ghc(9,11,0) |
| 261 | + = hmi { hm_iface = set_mi_top_env (Just $ IfaceTopEnv (forceGlobalRdrEnv (globalRdrEnvLocal rdr_env)) (mkIfaceImports $ tcg_import_decls tm)) iface} |
| 262 | +#else |
| 263 | + = hmi { hm_iface = iface { mi_globals = Just $! |
| 264 | +#if MIN_VERSION_ghc(9,8,0) |
| 265 | + forceGlobalRdrEnv |
| 266 | +#endif |
| 267 | + rdr_env |
| 268 | + }} |
| 269 | +#endif |
| 270 | + | otherwise = hmi |
| 271 | + |
| 272 | + return (ms, linkable_hsc) |
| 273 | + -- Bit awkward we need to use evalGhcEnv here but setContext requires to run |
| 274 | + -- in the Ghc monad |
| 275 | + env2 <- liftIO $ evalGhcEnv env1 $ do |
| 276 | + setContext [Compat.IIModule (moduleName (ms_mod ms))] |
| 277 | + let df = flip xopt_set LangExt.ExtendedDefaultRules |
| 278 | + . flip xopt_unset LangExt.MonomorphismRestriction |
| 279 | + . flip gopt_set Opt_ImplicitImportQualified |
| 280 | + . flip gopt_unset Opt_DiagnosticsShowCaret |
| 281 | + . setBackend ghciBackend |
| 282 | + $ (ms_hspp_opts ms) { |
| 283 | + useColor = Never |
| 284 | + , canUseColor = False } |
| 285 | + modifyDynFlags (const df) |
| 286 | + |
| 287 | + Compat.getSession |
| 288 | + return env2 |
| 289 | + |
| 290 | +newtype RenderingVar = RenderingVar (IORef (HashSet NormalizedFilePath)) |
| 291 | +instance IsIdeGlobal RenderingVar |
| 292 | + |
| 293 | +data IsRendering = IsRendering |
| 294 | + deriving (Eq, Show, Generic) |
| 295 | +instance Hashable IsRendering |
| 296 | +instance NFData IsRendering |
| 297 | + |
| 298 | +type instance RuleResult IsRendering = Bool |
| 299 | + |
| 300 | +queueForEvaluation :: IdeState -> NormalizedFilePath -> IO () |
| 301 | +queueForEvaluation ide nfp = do |
| 302 | + RenderingVar var <- getIdeGlobalState ide |
| 303 | + atomicModifyIORef' var (\fs -> (Set.insert nfp fs, ())) |
| 304 | + |
| 305 | +unqueueForEvaluation :: IdeState -> NormalizedFilePath -> IO () |
| 306 | +unqueueForEvaluation ide nfp = do |
| 307 | + RenderingVar var <- getIdeGlobalState ide |
| 308 | + -- remove the module from the Evaluating state, so that next time it won't evaluate to True |
| 309 | + atomicModifyIORef' var $ \fs -> (Set.delete nfp fs, ()) |
| 310 | + |
| 311 | +splitImportsAndDecls :: String -> ([String], String) |
| 312 | +splitImportsAndDecls src = go [] (lines src) |
| 313 | + where |
| 314 | + go imports ("":rest) = go imports rest |
| 315 | + go imports remainder@(line:rest) |
| 316 | + | "import" `isPrefixOf` line = go (line:imports) rest |
| 317 | + | otherwise = (imports, unlines remainder) |
| 318 | + go imports [] = (imports, "") |
| 319 | + |
| 320 | +addImport :: GhcMonad m => String -> m [InteractiveImport] |
| 321 | +addImport i = do |
| 322 | + ctx <- getContext |
| 323 | + idecl <- parseImportDecl i |
| 324 | + setContext $ IIDecl idecl : ctx |
| 325 | + getContext |
| 326 | + |
| 327 | +runInGhcEnv :: MonadIO m => PluginId -> IdeState -> FilePath -> ([Name] -> ExecOptions -> Ghc b) -> m b |
| 328 | +runInGhcEnv plId st fp ghcAction = liftIO $ do |
| 329 | + let nfp = toNormalizedFilePath' fp |
| 330 | + actionsFile <- liftIO $ runAction "Render: Config" st $ render_cfg_filepath <$> getRenderConfig plId |
| 331 | + (imports, decls) <- liftIO $ splitImportsAndDecls <$> readFile actionsFile |
| 332 | + |
| 333 | + -- enable codegen for the module which we need to evaluate. |
| 334 | + final_hscEnv <- liftIO $ bracket_ |
| 335 | + (setSomethingModified VFSUnmodified st "Render" $ do |
| 336 | + queueForEvaluation st nfp |
| 337 | + return [toKey IsRendering nfp] |
| 338 | + ) |
| 339 | + (setSomethingModified VFSUnmodified st "Render" $ do |
| 340 | + unqueueForEvaluation st nfp |
| 341 | + return [toKey IsRendering nfp] |
| 342 | + ) |
| 343 | + (initialiseSessionForEval st nfp) |
| 344 | + let l = 0 |
| 345 | + let opts = execOptions{execSourceFile = fp, execLineNumber = l} |
| 346 | + evalGhcEnv final_hscEnv $ do |
| 347 | + traverse_ addImport imports |
| 348 | + names <- runDecls decls |
| 349 | + ghcAction names opts |
| 350 | + |
| 351 | +runRenderCmd :: Recorder (WithPriority Log) -> PluginId -> CommandFunction IdeState RenderParams |
| 352 | +runRenderCmd recorder plId st mtoken param@RenderParams{..} = |
| 353 | + let action = |
| 354 | + do |
| 355 | + logWith recorder Debug (LogRunningRenderAction param) |
| 356 | + let TextDocumentIdentifier{_uri} = paramModuleName |
| 357 | + fp <- uriToFilePathE _uri |
| 358 | + _ <- runInGhcEnv plId st fp $ \_names opts -> do |
| 359 | + execStmt (paramAction <> " " <> paramValue) opts |
| 360 | + pure $ InR Null |
| 361 | + in ExceptT $ |
| 362 | + pluginWithIndefiniteProgress "Rendering" mtoken Cancellable $ const (runExceptT action) |
| 363 | + |
| 364 | + |
| 365 | +renderCommand :: Recorder (WithPriority Log) -> PluginId -> PluginCommand IdeState |
| 366 | +renderCommand recorder plId = PluginCommand renderCommandName "run action" (runRenderCmd recorder plId) |
| 367 | + |
| 368 | +-- Redefine the NeedsCompilation rule to set the linkable type to Just _ |
| 369 | +-- whenever the module is being evaluated |
| 370 | +-- This will ensure that the modules are loaded with linkables |
| 371 | +-- and the interactive session won't try to compile them on the fly, |
| 372 | +-- leading to much better performance of the evaluate code lens |
| 373 | +redefinedNeedsCompilation :: Recorder (WithPriority Log) -> Rules () |
| 374 | +redefinedNeedsCompilation recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation f -> do |
| 375 | + isRendering <- use_ IsRendering f |
| 376 | + if isRendering then do |
| 377 | + let linkableType = BCOLinkable |
| 378 | + fp = encodeLinkableType $ Just linkableType |
| 379 | + pure (Just fp, Just (Just linkableType)) |
| 380 | + else |
| 381 | + needsCompilationRule f |
| 382 | + |
| 383 | +isRenderingRule :: Recorder (WithPriority Log) -> Rules () |
| 384 | +isRenderingRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsRendering f -> do |
| 385 | + alwaysRerun |
| 386 | + RenderingVar var <- getIdeGlobalAction |
| 387 | + b <- liftIO $ (f `Set.member`) <$> readIORef var |
| 388 | + return (Just (if b then BS.singleton 1 else BS.empty), Just b) |
| 389 | + |
| 390 | +rules :: Recorder (WithPriority Log) -> Rules () |
| 391 | +rules recorder = do |
| 392 | + redefinedNeedsCompilation recorder |
| 393 | + isRenderingRule recorder |
| 394 | + addIdeGlobal . RenderingVar =<< liftIO(newIORef mempty) |
| 395 | + |
| 396 | +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState |
| 397 | +descriptor recorder plId = |
| 398 | + (defaultPluginDescriptor plId "Provides a mechanism to evaluate values using code lenses") |
| 399 | + { pluginHandlers = mconcat |
| 400 | + [ mkPluginHandler SMethod_TextDocumentCodeLens (codeLensHandler recorder) |
| 401 | + ] |
| 402 | + , pluginCommands = [renderCommand recorder plId] |
| 403 | + , pluginRules = rules recorder |
| 404 | + , pluginConfigDescriptor = defaultConfigDescriptor |
| 405 | + { configCustomConfig = mkCustomConfig properties |
| 406 | + } |
| 407 | + } |
0 commit comments