From 7ef8f4ff72d17dcb239dab68c98f5cfbabdaae45 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Sat, 8 May 2021 18:22:10 -0700 Subject: [PATCH 1/8] Add a hook for modifying the dynflags from a plugin --- .../session-loader/Development/IDE/Session.hs | 11 ---------- ghcide/src/Development/IDE/Core/Rules.hs | 20 ++++++++++++++----- ghcide/src/Development/IDE/Core/Service.hs | 6 +++++- ghcide/src/Development/IDE/Core/Shake.hs | 9 ++++++--- ghcide/src/Development/IDE/Main.hs | 7 ++++--- ghcide/src/Development/IDE/Plugin.hs | 8 ++++++-- ghcide/src/Development/IDE/Plugin/HLS.hs | 16 ++++++++++----- ghcide/src/Development/IDE/Plugin/Test.hs | 8 +++++--- hls-plugin-api/hls-plugin-api.cabal | 1 + hls-plugin-api/src/Ide/Types.hs | 16 +++++++++++++++ .../hls-tactics-plugin/src/Wingman/Plugin.hs | 13 ++++++++++++ 11 files changed, 82 insertions(+), 33 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 4ccbe0fa93..449d6bd3f2 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -84,7 +84,6 @@ import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TQueue import qualified Data.HashSet as Set import Database.SQLite.Simple -import GHC.LanguageExtensions (Extension (EmptyCase)) import HieDb.Create import HieDb.Types import HieDb.Utils @@ -794,7 +793,6 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do setIgnoreInterfacePragmas $ setLinkerOptions $ disableOptimisation $ - allowEmptyCaseButWithWarning $ setUpTypedHoles $ makeDynFlagsAbsolute compRoot dflags' -- initPackages parses the -package flags and @@ -803,15 +801,6 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do (final_df, _) <- liftIO $ wrapPackageSetupException $ initPackages dflags'' return (final_df, targets) - --- | Wingman wants to support destructing of empty cases, but these are a parse --- error by default. So we want to enable 'EmptyCase', but then that leads to --- silent errors without 'Opt_WarnIncompletePatterns'. -allowEmptyCaseButWithWarning :: DynFlags -> DynFlags -allowEmptyCaseButWithWarning = - flip xopt_set EmptyCase . flip wopt_set Opt_WarnIncompletePatterns - - -- we don't want to generate object code so we compile to bytecode -- (HscInterpreted) which implies LinkInMemory -- HscInterpreted diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index d4525d8dd3..a021d0414f 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -111,7 +111,7 @@ import Development.IDE.GHC.Compat hiding writeHieFile) import Development.IDE.GHC.Error import Development.IDE.GHC.ExactPrint -import Development.IDE.GHC.Util +import Development.IDE.GHC.Util hiding (modifyDynFlags) import Development.IDE.Import.DependencyInformation import Development.IDE.Import.FindImports import qualified Development.IDE.Spans.AtPoint as AtPoint @@ -140,7 +140,7 @@ import Module import TcRnMonad (tcg_dependent_files) import Ide.Plugin.Properties (HasProperty, KeyNameProxy, Properties, ToHsType, useProperty) -import Ide.Types (PluginId) +import Ide.Types (PluginId, DynFlagsModifications(dynFlagsModifyGlobal, dynFlagsModifyParser)) import Data.Default (def) import Ide.PluginUtils (configForPlugin) import Control.Applicative @@ -211,10 +211,12 @@ getParsedModuleRule :: Rules () getParsedModuleRule = -- this rule does not have early cutoff since all its dependencies already have it define $ \GetParsedModule file -> do - ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary file + ModSummaryResult{msrModSummary = ms'} <- use_ GetModSummary file sess <- use_ GhcSession file let hsc = hscEnv sess opt <- getIdeOptions + modify_dflags <- getModifyDynFlags id dynFlagsModifyParser + let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' } let dflags = ms_hspp_opts ms mainParse = getParsedModuleDefinition hsc opt file ms @@ -284,8 +286,14 @@ getParsedModuleWithCommentsRule = opt <- getIdeOptions let ms' = withoutOption Opt_Haddock $ withOption Opt_KeepRawTokenStream ms + modify_dflags <- getModifyDynFlags id dynFlagsModifyParser + let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' } + + liftIO $ snd <$> getParsedModuleDefinition (hscEnv sess) opt file ms + +getModifyDynFlags :: a -> (DynFlagsModifications -> a) -> Action a +getModifyDynFlags a f = maybe a (f . dynFlagsMods) <$> getShakeExtra - liftIO $ snd <$> getParsedModuleDefinition (hscEnv sess) opt file ms' getParsedModuleDefinition :: HscEnv @@ -782,7 +790,9 @@ isHiFileStableRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsHiFileStable f - getModSummaryRule :: Rules () getModSummaryRule = do defineEarlyCutoff $ Rule $ \GetModSummary f -> do - session <- hscEnv <$> use_ GhcSession f + session' <- hscEnv <$> use_ GhcSession f + modify_dflags <- getModifyDynFlags id dynFlagsModifyGlobal + let session = session' { hsc_dflags = modify_dflags $ hsc_dflags session' } (modTime, mFileContent) <- getFileContents f let fp = fromNormalizedFilePath f modS <- liftIO $ runExceptT $ diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index b03da9fd42..c11d4cec12 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -30,6 +30,8 @@ import qualified Language.LSP.Types as LSP import Control.Monad import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat (DynFlags) +import Ide.Types (DynFlagsModifications) ------------------------------------------------------------ @@ -38,6 +40,7 @@ import Development.IDE.Core.Shake -- | Initialise the Compiler Service. initialise :: Config -> Rules () + -> DynFlagsModifications -> Maybe (LSP.LanguageContextEnv Config) -> Logger -> Debouncer LSP.NormalizedUri @@ -46,10 +49,11 @@ initialise :: Config -> HieDb -> IndexQueue -> IO IdeState -initialise defaultConfig mainRule lspEnv logger debouncer options vfs hiedb hiedbChan = +initialise defaultConfig mainRule dynFlagsMods lspEnv logger debouncer options vfs hiedb hiedbChan = shakeOpen lspEnv defaultConfig + dynFlagsMods logger debouncer (optShakeProfiling options) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 52463e51f6..39c6c42525 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -147,8 +147,9 @@ import Control.Exception.Extra hiding (bracket_) import Data.Default import HieDb.Types import Ide.Plugin.Config -import qualified Ide.PluginUtils as HLS -import Ide.Types (PluginId) +import qualified Ide.PluginUtils as HLS +import Ide.Types (PluginId, DynFlagsModifications) +import DynFlags (DynFlags) -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by @@ -171,6 +172,7 @@ data ShakeExtras = ShakeExtras lspEnv :: Maybe (LSP.LanguageContextEnv Config) ,debouncer :: Debouncer NormalizedUri ,logger :: Logger + ,dynFlagsMods :: DynFlagsModifications ,globals :: Var (HMap.HashMap TypeRep Dynamic) ,state :: Var Values ,diagnostics :: Var DiagnosticStore @@ -454,6 +456,7 @@ seqValue v b = case v of -- | Open a 'IdeState', should be shut using 'shakeShut'. shakeOpen :: Maybe (LSP.LanguageContextEnv Config) -> Config + -> DynFlagsModifications -> Logger -> Debouncer NormalizedUri -> Maybe FilePath @@ -465,7 +468,7 @@ shakeOpen :: Maybe (LSP.LanguageContextEnv Config) -> ShakeOptions -> Rules () -> IO IdeState -shakeOpen lspEnv defaultConfig logger debouncer +shakeOpen lspEnv defaultConfig dynFlagsMods logger debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo us <- mkSplitUniqSupply 'r' diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index c3a34415cc..1655b329ad 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -46,7 +46,7 @@ import Development.IDE.Core.Shake (IdeState (shakeExtras), import Development.IDE.Core.Tracing (measureMemory) import Development.IDE.Graph (action) import Development.IDE.LSP.LanguageServer (runLanguageServer) -import Development.IDE.Plugin (Plugin (pluginHandlers, pluginRules)) +import Development.IDE.Plugin (Plugin (pluginHandlers, pluginRules, pluginModifyDynflags)) import Development.IDE.Plugin.HLS (asGhcIdePlugin) import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide import Development.IDE.Session (SessionLoadingOptions, @@ -223,6 +223,7 @@ defaultMain Arguments{..} = do initialise argsDefaultHlsConfig rules + (pluginModifyDynflags plugins) (Just env) logger debouncer @@ -260,7 +261,7 @@ defaultMain Arguments{..} = do { optCheckParents = pure NeverCheck , optCheckProject = pure False } - ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan + ide <- initialise argsDefaultHlsConfig rules (pluginModifyDynflags plugins) Nothing logger debouncer options vfs hiedb hieChan shakeSessionInit ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -309,7 +310,7 @@ defaultMain Arguments{..} = do { optCheckParents = pure NeverCheck, optCheckProject = pure False } - ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan + ide <- initialise argsDefaultHlsConfig rules (pluginModifyDynflags plugins) Nothing logger debouncer options vfs hiedb hieChan shakeSessionInit ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide diff --git a/ghcide/src/Development/IDE/Plugin.hs b/ghcide/src/Development/IDE/Plugin.hs index c29e6a5470..95d9f2a226 100644 --- a/ghcide/src/Development/IDE/Plugin.hs +++ b/ghcide/src/Development/IDE/Plugin.hs @@ -5,17 +5,21 @@ import Development.IDE.Graph import Development.IDE.LSP.Server import qualified Language.LSP.Server as LSP +import Development.IDE.GHC.Compat (DynFlags) +import Data.Monoid (Endo) +import Ide.Types (DynFlagsModifications) data Plugin c = Plugin {pluginRules :: Rules () ,pluginHandlers :: LSP.Handlers (ServerM c) + ,pluginModifyDynflags :: DynFlagsModifications } instance Default (Plugin c) where - def = Plugin mempty mempty + def = Plugin mempty mempty mempty instance Semigroup (Plugin c) where - Plugin x1 h1 <> Plugin x2 h2 = Plugin (x1<>x2) (h1 <> h2) + Plugin x1 h1 d1 <> Plugin x2 h2 d2 = Plugin (x1<>x2) (h1 <> h2) (d1 <> d2) instance Monoid (Plugin c) where mempty = def diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index c208a2c21e..c957bee171 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -26,6 +26,7 @@ import Development.IDE.Core.Shake import Development.IDE.Core.Tracing import Development.IDE.LSP.Server import Development.IDE.Plugin +import qualified Development.IDE.Plugin as P import Development.IDE.Types.Logger import Development.IDE.Graph (Rules) import Ide.Plugin.Config @@ -38,6 +39,7 @@ import Text.Regex.TDFA.Text () import UnliftIO (MonadUnliftIO) import UnliftIO.Async (forConcurrently) import UnliftIO.Exception (catchAny) +import Development.IDE.GHC.Compat (DynFlags) -- --------------------------------------------------------------------- -- @@ -48,7 +50,8 @@ asGhcIdePlugin (IdePlugins ls) = mkPlugin rulesPlugins HLS.pluginRules <> mkPlugin executeCommandPlugins HLS.pluginCommands <> mkPlugin extensiblePlugins HLS.pluginHandlers <> - mkPlugin extensibleNotificationPlugins HLS.pluginNotificationHandlers + mkPlugin extensibleNotificationPlugins HLS.pluginNotificationHandlers <> + mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags where mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> b) -> Plugin Config @@ -63,14 +66,17 @@ asGhcIdePlugin (IdePlugins ls) = -- --------------------------------------------------------------------- rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config -rulesPlugins rs = Plugin rules mempty +rulesPlugins rs = mempty { P.pluginRules = rules } where rules = foldMap snd rs +dynFlagsPlugins :: [(PluginId, DynFlagsModifications)] -> Plugin Config +dynFlagsPlugins rs = mempty { P.pluginModifyDynflags = foldMap snd rs } + -- --------------------------------------------------------------------- executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config -executeCommandPlugins ecs = Plugin mempty (executeCommandHandlers ecs) +executeCommandPlugins ecs = mempty { P.pluginHandlers = executeCommandHandlers ecs } executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config) executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd @@ -132,7 +138,7 @@ executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd -- --------------------------------------------------------------------- extensiblePlugins :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config -extensiblePlugins xs = Plugin mempty handlers +extensiblePlugins xs = mempty { P.pluginHandlers = handlers } where IdeHandlers handlers' = foldMap bakePluginId xs bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers @@ -160,7 +166,7 @@ extensiblePlugins xs = Plugin mempty handlers -- --------------------------------------------------------------------- extensibleNotificationPlugins :: [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config -extensibleNotificationPlugins xs = Plugin mempty handlers +extensibleNotificationPlugins xs = mempty { P.pluginHandlers = handlers } where IdeNotificationHandlers handlers' = foldMap bakePluginId xs bakePluginId :: (PluginId, PluginNotificationHandlers IdeState) -> IdeNotificationHandlers diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index e8643d9471..47fa49f14f 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -37,6 +37,8 @@ import Ide.Types import qualified Language.LSP.Server as LSP import Language.LSP.Types import System.Time.Extra +import qualified Development.IDE.Plugin as P +import Data.Default (def) data TestRequest = BlockSeconds Seconds -- ^ :: Null @@ -51,9 +53,9 @@ newtype WaitForIdeRuleResult = WaitForIdeRuleResult { ideResultSuccess::Bool} deriving newtype (FromJSON, ToJSON) plugin :: Plugin c -plugin = Plugin { - pluginRules = return (), - pluginHandlers = requestHandler (SCustomMethod "test") testRequestHandler' +plugin = def { + P.pluginRules = return (), + P.pluginHandlers = requestHandler (SCustomMethod "test") testRequestHandler' } where testRequestHandler' ide req diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index acec2485d4..c486e7a96b 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -43,6 +43,7 @@ library , dependent-sum , Diff ^>=0.4.0 , dlist + , ghc , hashable , hslogger , lens diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index c17171b2f0..52ede7dc6e 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -50,12 +50,26 @@ import Language.LSP.VFS import OpenTelemetry.Eventlog import System.IO.Unsafe import Text.Regex.TDFA.Text () +import DynFlags (DynFlags) -- --------------------------------------------------------------------- newtype IdePlugins ideState = IdePlugins { ipMap :: [(PluginId, PluginDescriptor ideState)]} +data DynFlagsModifications = + DynFlagsModifications { dynFlagsModifyGlobal :: DynFlags -> DynFlags + , dynFlagsModifyParser :: DynFlags -> DynFlags + } + +instance Semigroup DynFlagsModifications where + DynFlagsModifications g1 p1 <> DynFlagsModifications g2 p2 = + DynFlagsModifications (g2 . g1) (p2 . p1) + +instance Monoid DynFlagsModifications where + mempty = DynFlagsModifications id id + + -- --------------------------------------------------------------------- data PluginDescriptor ideState = @@ -65,6 +79,7 @@ data PluginDescriptor ideState = , pluginHandlers :: PluginHandlers ideState , pluginConfigDescriptor :: ConfigDescriptor , pluginNotificationHandlers :: PluginNotificationHandlers ideState + , pluginModifyDynflags :: DynFlagsModifications } -- | An existential wrapper of 'Properties' @@ -297,6 +312,7 @@ defaultPluginDescriptor plId = mempty defaultConfigDescriptor mempty + mempty newtype CommandId = CommandId T.Text deriving (Show, Read, Eq, Ord) diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index 58cfd7b9ad..dee54a2025 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -37,6 +37,7 @@ import Wingman.Machinery (scoreSolution) import Wingman.Range import Wingman.Tactics import Wingman.Types +import GHC.LanguageExtensions.Type (Extension(EmptyCase)) descriptor :: PluginId -> PluginDescriptor IdeState @@ -62,9 +63,21 @@ descriptor plId = (defaultPluginDescriptor plId) , pluginRules = wingmanRules plId , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} + , pluginModifyDynflags = mempty + { dynFlagsModifyGlobal = allowEmptyCaseButWithWarning + } } +-- | Wingman wants to support destructing of empty cases, but these are a parse +-- error by default. So we want to enable 'EmptyCase', but then that leads to +-- silent errors without 'Opt_WarnIncompletePatterns'. +allowEmptyCaseButWithWarning :: DynFlags -> DynFlags +allowEmptyCaseButWithWarning = + flip xopt_set EmptyCase . flip wopt_set Opt_WarnIncompletePatterns + + + codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction codeActionProvider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) (unsafeMkCurrent -> range) _ctx) | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do From 916a93df2485c029489c721dd9f781a5b15ec94d Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Sat, 8 May 2021 18:34:11 -0700 Subject: [PATCH 2/8] Tidy --- ghcide/src/Development/IDE/Core/Service.hs | 5 ++--- ghcide/src/Development/IDE/Core/Shake.hs | 1 - ghcide/src/Development/IDE/Plugin.hs | 4 +--- ghcide/src/Development/IDE/Plugin/HLS.hs | 1 - hls-plugin-api/src/Ide/Types.hs | 2 +- plugins/hls-tactics-plugin/src/Wingman/Plugin.hs | 2 +- 6 files changed, 5 insertions(+), 10 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index c11d4cec12..71a80d7744 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -21,17 +21,16 @@ module Development.IDE.Core.Service( import Development.IDE.Core.Debouncer import Development.IDE.Core.FileExists (fileExistsRules) import Development.IDE.Core.OfInterest +import Development.IDE.Graph import Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options (IdeOptions (..)) -import Development.IDE.Graph import Ide.Plugin.Config +import Ide.Types (DynFlagsModifications) import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP import Control.Monad import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat (DynFlags) -import Ide.Types (DynFlagsModifications) ------------------------------------------------------------ diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 39c6c42525..b41d9e45e6 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -149,7 +149,6 @@ import HieDb.Types import Ide.Plugin.Config import qualified Ide.PluginUtils as HLS import Ide.Types (PluginId, DynFlagsModifications) -import DynFlags (DynFlags) -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by diff --git a/ghcide/src/Development/IDE/Plugin.hs b/ghcide/src/Development/IDE/Plugin.hs index 95d9f2a226..cae8173b71 100644 --- a/ghcide/src/Development/IDE/Plugin.hs +++ b/ghcide/src/Development/IDE/Plugin.hs @@ -4,10 +4,8 @@ import Data.Default import Development.IDE.Graph import Development.IDE.LSP.Server +import Ide.Types (DynFlagsModifications) import qualified Language.LSP.Server as LSP -import Development.IDE.GHC.Compat (DynFlags) -import Data.Monoid (Endo) -import Ide.Types (DynFlagsModifications) data Plugin c = Plugin {pluginRules :: Rules () diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index c957bee171..8b63c147d1 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -39,7 +39,6 @@ import Text.Regex.TDFA.Text () import UnliftIO (MonadUnliftIO) import UnliftIO.Async (forConcurrently) import UnliftIO.Exception (catchAny) -import Development.IDE.GHC.Compat (DynFlags) -- --------------------------------------------------------------------- -- diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 52ede7dc6e..f12dc3ad65 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -39,6 +39,7 @@ import Data.String import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Development.IDE.Graph +import DynFlags (DynFlags) import GHC.Generics import Ide.Plugin.Config import Ide.Plugin.Properties @@ -50,7 +51,6 @@ import Language.LSP.VFS import OpenTelemetry.Eventlog import System.IO.Unsafe import Text.Regex.TDFA.Text () -import DynFlags (DynFlags) -- --------------------------------------------------------------------- diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index dee54a2025..935d8d6736 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -20,6 +20,7 @@ import Development.IDE.Core.Shake (IdeState (..)) import Development.IDE.Core.UseStale (Tracked, TrackedStale(..), unTrack, mapAgeFrom, unsafeMkCurrent) import Development.IDE.GHC.Compat import Development.IDE.GHC.ExactPrint +import GHC.LanguageExtensions.Type (Extension(EmptyCase)) import Generics.SYB.GHC import Ide.Types import Language.LSP.Server @@ -37,7 +38,6 @@ import Wingman.Machinery (scoreSolution) import Wingman.Range import Wingman.Tactics import Wingman.Types -import GHC.LanguageExtensions.Type (Extension(EmptyCase)) descriptor :: PluginId -> PluginDescriptor IdeState From d45274010997aa1df06473fdd16823d55d2f3fbf Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 10 May 2021 10:07:17 -0700 Subject: [PATCH 3/8] Reset ModSummary --- ghcide/src/Development/IDE/Core/Rules.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index a021d0414f..37de89a3ea 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -220,11 +220,12 @@ getParsedModuleRule = let dflags = ms_hspp_opts ms mainParse = getParsedModuleDefinition hsc opt file ms + reset_ms pm = pm { pm_mod_summary = ms' } -- Parse again (if necessary) to capture Haddock parse errors res@(_,pmod) <- if gopt Opt_Haddock dflags then - liftIO mainParse + liftIO $ fmap (fmap (fmap reset_ms)) mainParse else do let haddockParse = getParsedModuleDefinition hsc opt file (withOptHaddock ms) @@ -234,7 +235,7 @@ getParsedModuleRule = -- If we can parse Haddocks, might as well use them -- -- HLINT INTEGRATION: might need to save the other parsed module too - ((diags,res),(diagsh,resh)) <- liftIO $ concurrently mainParse haddockParse + ((diags,res),(diagsh,resh)) <- liftIO $ fmap (fmap (fmap (fmap reset_ms))) $ concurrently mainParse haddockParse -- Merge haddock and regular diagnostics so we can always report haddock -- parse errors @@ -288,8 +289,9 @@ getParsedModuleWithCommentsRule = let ms' = withoutOption Opt_Haddock $ withOption Opt_KeepRawTokenStream ms modify_dflags <- getModifyDynFlags id dynFlagsModifyParser let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' } + reset_ms pm = pm { pm_mod_summary = ms' } - liftIO $ snd <$> getParsedModuleDefinition (hscEnv sess) opt file ms + liftIO $ fmap (fmap reset_ms) $ snd <$> getParsedModuleDefinition (hscEnv sess) opt file ms getModifyDynFlags :: a -> (DynFlagsModifications -> a) -> Action a getModifyDynFlags a f = maybe a (f . dynFlagsMods) <$> getShakeExtra From 1170c2bb6cfeee261197a7b019b205ab0d37d2b0 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 10 May 2021 10:41:10 -0700 Subject: [PATCH 4/8] Put the DynFlagsModifications in IdeOptions --- ghcide/session-loader/Development/IDE/Session.hs | 5 +++-- ghcide/src/Development/IDE/Core/Rules.hs | 10 +++++----- ghcide/src/Development/IDE/Core/Service.hs | 5 +---- ghcide/src/Development/IDE/Core/Shake.hs | 6 ++---- ghcide/src/Development/IDE/Main.hs | 14 ++++++++------ ghcide/src/Development/IDE/Types/Options.hs | 5 +++-- 6 files changed, 22 insertions(+), 23 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 449d6bd3f2..e887b0cfc0 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -87,6 +87,7 @@ import Database.SQLite.Simple import HieDb.Create import HieDb.Types import HieDb.Utils +import Ide.Types (dynFlagsModifyGlobal) -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String @@ -255,7 +256,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do IdeOptions{ optTesting = IdeTesting optTesting , optCheckProject = getCheckProject - , optCustomDynFlags + , optModifyDynFlags , optExtensions } <- getIdeOptions @@ -286,7 +287,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do -- Parse DynFlags for the newly discovered component hscEnv <- emptyHscEnv ideNc libDir (df, targets) <- evalGhcEnv hscEnv $ - first optCustomDynFlags <$> setOptions opts (hsc_dflags hscEnv) + first (dynFlagsModifyGlobal optModifyDynFlags) <$> setOptions opts (hsc_dflags hscEnv) let deps = componentDependencies opts ++ maybeToList hieYaml dep_info <- getDependencyInfo deps -- Now lookup to see whether we are combining with an existing HscEnv diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 37de89a3ea..41adc387ac 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -215,7 +215,7 @@ getParsedModuleRule = sess <- use_ GhcSession file let hsc = hscEnv sess opt <- getIdeOptions - modify_dflags <- getModifyDynFlags id dynFlagsModifyParser + modify_dflags <- getModifyDynFlags dynFlagsModifyParser let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' } let dflags = ms_hspp_opts ms @@ -287,14 +287,14 @@ getParsedModuleWithCommentsRule = opt <- getIdeOptions let ms' = withoutOption Opt_Haddock $ withOption Opt_KeepRawTokenStream ms - modify_dflags <- getModifyDynFlags id dynFlagsModifyParser + modify_dflags <- getModifyDynFlags dynFlagsModifyParser let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' } reset_ms pm = pm { pm_mod_summary = ms' } liftIO $ fmap (fmap reset_ms) $ snd <$> getParsedModuleDefinition (hscEnv sess) opt file ms -getModifyDynFlags :: a -> (DynFlagsModifications -> a) -> Action a -getModifyDynFlags a f = maybe a (f . dynFlagsMods) <$> getShakeExtra +getModifyDynFlags :: (DynFlagsModifications -> a) -> Action a +getModifyDynFlags f = f . optModifyDynFlags <$> getIdeOptions getParsedModuleDefinition @@ -793,7 +793,7 @@ getModSummaryRule :: Rules () getModSummaryRule = do defineEarlyCutoff $ Rule $ \GetModSummary f -> do session' <- hscEnv <$> use_ GhcSession f - modify_dflags <- getModifyDynFlags id dynFlagsModifyGlobal + modify_dflags <- getModifyDynFlags dynFlagsModifyGlobal let session = session' { hsc_dflags = modify_dflags $ hsc_dflags session' } (modTime, mFileContent) <- getFileContents f let fp = fromNormalizedFilePath f diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index 71a80d7744..542f06d079 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -25,7 +25,6 @@ import Development.IDE.Graph import Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options (IdeOptions (..)) import Ide.Plugin.Config -import Ide.Types (DynFlagsModifications) import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP @@ -39,7 +38,6 @@ import Development.IDE.Core.Shake -- | Initialise the Compiler Service. initialise :: Config -> Rules () - -> DynFlagsModifications -> Maybe (LSP.LanguageContextEnv Config) -> Logger -> Debouncer LSP.NormalizedUri @@ -48,11 +46,10 @@ initialise :: Config -> HieDb -> IndexQueue -> IO IdeState -initialise defaultConfig mainRule dynFlagsMods lspEnv logger debouncer options vfs hiedb hiedbChan = +initialise defaultConfig mainRule lspEnv logger debouncer options vfs hiedb hiedbChan = shakeOpen lspEnv defaultConfig - dynFlagsMods logger debouncer (optShakeProfiling options) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index b41d9e45e6..c2b9492abd 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -148,7 +148,7 @@ import Data.Default import HieDb.Types import Ide.Plugin.Config import qualified Ide.PluginUtils as HLS -import Ide.Types (PluginId, DynFlagsModifications) +import Ide.Types (PluginId) -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by @@ -171,7 +171,6 @@ data ShakeExtras = ShakeExtras lspEnv :: Maybe (LSP.LanguageContextEnv Config) ,debouncer :: Debouncer NormalizedUri ,logger :: Logger - ,dynFlagsMods :: DynFlagsModifications ,globals :: Var (HMap.HashMap TypeRep Dynamic) ,state :: Var Values ,diagnostics :: Var DiagnosticStore @@ -455,7 +454,6 @@ seqValue v b = case v of -- | Open a 'IdeState', should be shut using 'shakeShut'. shakeOpen :: Maybe (LSP.LanguageContextEnv Config) -> Config - -> DynFlagsModifications -> Logger -> Debouncer NormalizedUri -> Maybe FilePath @@ -467,7 +465,7 @@ shakeOpen :: Maybe (LSP.LanguageContextEnv Config) -> ShakeOptions -> Rules () -> IO IdeState -shakeOpen lspEnv defaultConfig dynFlagsMods logger debouncer +shakeOpen lspEnv defaultConfig logger debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo us <- mkSplitUniqSupply 'r' diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 1655b329ad..fe7a081639 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -60,7 +60,7 @@ import Development.IDE.Types.Logger (Logger (Logger)) import Development.IDE.Types.Options (IdeGhcSession, IdeOptions (optCheckParents, optCheckProject, optReportProgress), clientSupportsProgress, - defaultIdeOptions) + defaultIdeOptions, optModifyDynFlags) import Development.IDE.Types.Shake (Key (Key)) import GHC.IO.Encoding (setLocaleEncoding) import GHC.IO.Handle (hDuplicate) @@ -218,12 +218,12 @@ defaultMain Arguments{..} = do config <- LSP.runLspT env LSP.getConfig let options = (argsIdeOptions config sessionLoader) { optReportProgress = clientSupportsProgress caps + , optModifyDynFlags = pluginModifyDynflags plugins } caps = LSP.resClientCapabilities env initialise argsDefaultHlsConfig rules - (pluginModifyDynflags plugins) (Just env) logger debouncer @@ -260,8 +260,9 @@ defaultMain Arguments{..} = do let options = (argsIdeOptions argsDefaultHlsConfig sessionLoader) { optCheckParents = pure NeverCheck , optCheckProject = pure False + , optModifyDynFlags = pluginModifyDynflags plugins } - ide <- initialise argsDefaultHlsConfig rules (pluginModifyDynflags plugins) Nothing logger debouncer options vfs hiedb hieChan + ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan shakeSessionInit ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -307,10 +308,11 @@ defaultMain Arguments{..} = do sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "." let options = (argsIdeOptions argsDefaultHlsConfig sessionLoader) - { optCheckParents = pure NeverCheck, - optCheckProject = pure False + { optCheckParents = pure NeverCheck + , optCheckProject = pure False + , optModifyDynFlags = pluginModifyDynflags plugins } - ide <- initialise argsDefaultHlsConfig rules (pluginModifyDynflags plugins) Nothing logger debouncer options vfs hiedb hieChan + ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan shakeSessionInit ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index cd07c88116..30d59f4389 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -28,6 +28,7 @@ import GHC hiding (parseModule, typecheckModule) import GhcPlugins as GHC hiding (fst3, (<>)) import Ide.Plugin.Config +import Ide.Types (DynFlagsModifications) import qualified Language.LSP.Types.Capabilities as LSP data IdeOptions = IdeOptions @@ -73,7 +74,7 @@ data IdeOptions = IdeOptions -- Otherwise, return the result of parsing without Opt_Haddock, so -- that the parsed module contains the result of Opt_KeepRawTokenStream, -- which might be necessary for hlint. - , optCustomDynFlags :: DynFlags -> DynFlags + , optModifyDynFlags :: DynFlagsModifications -- ^ Will be called right after setting up a new cradle, -- allowing to customize the Ghc options used , optShakeOptions :: ShakeOptions @@ -138,7 +139,7 @@ defaultIdeOptions session = IdeOptions ,optCheckProject = pure True ,optCheckParents = pure CheckOnSaveAndClose ,optHaddockParse = HaddockParse - ,optCustomDynFlags = id + ,optModifyDynFlags = mempty ,optSkipProgress = defaultSkipProgress ,optProgressStyle = Explicit } From e13f88531b8d0a17a4c0ba0793f9ec45eb33089e Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 10 May 2021 10:49:26 -0700 Subject: [PATCH 5/8] Add Haddock --- hls-plugin-api/src/Ide/Types.hs | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index f12dc3ad65..00afd5892d 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -57,10 +57,21 @@ import Text.Regex.TDFA.Text () newtype IdePlugins ideState = IdePlugins { ipMap :: [(PluginId, PluginDescriptor ideState)]} +-- | Hooks for modifying the 'DynFlags' at different times of the compilation +-- process. Plugins can install a 'DynFlagsModifications' via +-- 'pluginModifyDynflags' in their 'PluginDescriptor'. data DynFlagsModifications = - DynFlagsModifications { dynFlagsModifyGlobal :: DynFlags -> DynFlags - , dynFlagsModifyParser :: DynFlags -> DynFlags - } + DynFlagsModifications + { -- | Invoked immediately at the package level. Changes to the 'DynFlags' + -- made in 'dynFlagsModifyGlobal' are guaranteed to be seen everywhere in + -- the compilation pipeline. + dynFlagsModifyGlobal :: DynFlags -> DynFlags + -- | Invoked just before the parsing step, and reset immediately + -- afterwards. 'dynFlagsModifyParser' allows plugins to enable language + -- extensions only during parsing. for example, to let them enable + -- certain pieces of syntax. + , dynFlagsModifyParser :: DynFlags -> DynFlags + } instance Semigroup DynFlagsModifications where DynFlagsModifications g1 p1 <> DynFlagsModifications g2 p2 = From 4f3875e64e5dbb5da2b3b204a829c1548fd8e1ba Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Mon, 10 May 2021 11:20:12 -0700 Subject: [PATCH 6/8] Keep the old optModifyDynFlags --- ghcide/src/Development/IDE/Main.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index fe7a081639..3de80e6092 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -216,9 +216,10 @@ defaultMain Arguments{..} = do sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions $ fromMaybe dir rootPath config <- LSP.runLspT env LSP.getConfig - let options = (argsIdeOptions config sessionLoader) + let def_options = argsIdeOptions config sessionLoader + options = def_options { optReportProgress = clientSupportsProgress caps - , optModifyDynFlags = pluginModifyDynflags plugins + , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } caps = LSP.resClientCapabilities env initialise @@ -257,10 +258,11 @@ defaultMain Arguments{..} = do putStrLn "\nStep 3/4: Initializing the IDE" vfs <- makeVFSHandle sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir - let options = (argsIdeOptions argsDefaultHlsConfig sessionLoader) + let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader + options = def_options { optCheckParents = pure NeverCheck , optCheckProject = pure False - , optModifyDynFlags = pluginModifyDynflags plugins + , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan shakeSessionInit ide @@ -306,11 +308,11 @@ defaultMain Arguments{..} = do runWithDb dbLoc $ \hiedb hieChan -> do vfs <- makeVFSHandle sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "." - let options = - (argsIdeOptions argsDefaultHlsConfig sessionLoader) + let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader + options = def_options { optCheckParents = pure NeverCheck , optCheckProject = pure False - , optModifyDynFlags = pluginModifyDynflags plugins + , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan shakeSessionInit ide From 98ea87acb06111357ff36a63107707c8f7ac44fd Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Tue, 11 May 2021 08:58:50 -0700 Subject: [PATCH 7/8] Update ghcide/src/Development/IDE/Core/Rules.hs Co-authored-by: Pepe Iborra --- ghcide/src/Development/IDE/Core/Rules.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 41adc387ac..01a5f7f93e 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -225,7 +225,7 @@ getParsedModuleRule = -- Parse again (if necessary) to capture Haddock parse errors res@(_,pmod) <- if gopt Opt_Haddock dflags then - liftIO $ fmap (fmap (fmap reset_ms)) mainParse + liftIO $ (fmap.fmap.fmap) reset_ms mainParse else do let haddockParse = getParsedModuleDefinition hsc opt file (withOptHaddock ms) From 1ed5fa8bd9fdf0fdf56a1f16c7b777c7522518ce Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Tue, 11 May 2021 08:58:59 -0700 Subject: [PATCH 8/8] Update ghcide/src/Development/IDE/Core/Rules.hs Co-authored-by: Pepe Iborra --- ghcide/src/Development/IDE/Core/Rules.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 01a5f7f93e..cafa74d60f 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -235,7 +235,7 @@ getParsedModuleRule = -- If we can parse Haddocks, might as well use them -- -- HLINT INTEGRATION: might need to save the other parsed module too - ((diags,res),(diagsh,resh)) <- liftIO $ fmap (fmap (fmap (fmap reset_ms))) $ concurrently mainParse haddockParse + ((diags,res),(diagsh,resh)) <- liftIO $ (fmap.fmap.fmap.fmap) reset_ms $ concurrently mainParse haddockParse -- Merge haddock and regular diagnostics so we can always report haddock -- parse errors