diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 4ccbe0fa93..e887b0cfc0 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -84,10 +84,10 @@ 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 +import Ide.Types (dynFlagsModifyGlobal) -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String @@ -256,7 +256,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do IdeOptions{ optTesting = IdeTesting optTesting , optCheckProject = getCheckProject - , optCustomDynFlags + , optModifyDynFlags , optExtensions } <- getIdeOptions @@ -287,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 @@ -794,7 +794,6 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do setIgnoreInterfacePragmas $ setLinkerOptions $ disableOptimisation $ - allowEmptyCaseButWithWarning $ setUpTypedHoles $ makeDynFlagsAbsolute compRoot dflags' -- initPackages parses the -package flags and @@ -803,15 +802,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 3930e4f5d4..cef2f8dc59 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 @@ -141,7 +141,7 @@ import System.Directory (canonicalizePath) 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 @@ -202,18 +202,21 @@ 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 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 + 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) @@ -223,7 +226,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 @@ -275,8 +278,15 @@ getParsedModuleWithCommentsRule = opt <- getIdeOptions let ms' = withoutOption Opt_Haddock $ withOption Opt_KeepRawTokenStream ms + 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 :: (DynFlagsModifications -> a) -> Action a +getModifyDynFlags f = f . optModifyDynFlags <$> getIdeOptions - liftIO $ snd <$> getParsedModuleDefinition (hscEnv sess) opt file ms' getParsedModuleDefinition :: HscEnv @@ -775,7 +785,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 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..542f06d079 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -21,9 +21,9 @@ 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 qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index f4b702b794..be0bc65313 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -148,8 +148,8 @@ 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) -- | 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/Main.hs b/ghcide/src/Development/IDE/Main.hs index c3a34415cc..3de80e6092 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, @@ -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) @@ -216,8 +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 = optModifyDynFlags def_options <> pluginModifyDynflags plugins } caps = LSP.resClientCapabilities env initialise @@ -256,9 +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 = optModifyDynFlags def_options <> pluginModifyDynflags plugins } ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan shakeSessionInit ide @@ -304,10 +308,11 @@ defaultMain Arguments{..} = do runWithDb dbLoc $ \hiedb hieChan -> do vfs <- makeVFSHandle sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "." - let options = - (argsIdeOptions argsDefaultHlsConfig sessionLoader) - { optCheckParents = pure NeverCheck, - optCheckProject = pure False + let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader + options = def_options + { optCheckParents = pure NeverCheck + , optCheckProject = pure False + , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan shakeSessionInit ide diff --git a/ghcide/src/Development/IDE/Plugin.hs b/ghcide/src/Development/IDE/Plugin.hs index c29e6a5470..cae8173b71 100644 --- a/ghcide/src/Development/IDE/Plugin.hs +++ b/ghcide/src/Development/IDE/Plugin.hs @@ -4,18 +4,20 @@ import Data.Default import Development.IDE.Graph import Development.IDE.LSP.Server +import Ide.Types (DynFlagsModifications) import qualified Language.LSP.Server as LSP 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..8b63c147d1 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 @@ -48,7 +49,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 +65,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 +137,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 +165,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/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 } diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index d2885f2ae8..11ee0eb004 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..00afd5892d 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 @@ -56,6 +57,30 @@ 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 + { -- | 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 = + DynFlagsModifications (g2 . g1) (p2 . p1) + +instance Monoid DynFlagsModifications where + mempty = DynFlagsModifications id id + + -- --------------------------------------------------------------------- data PluginDescriptor ideState = @@ -65,6 +90,7 @@ data PluginDescriptor ideState = , pluginHandlers :: PluginHandlers ideState , pluginConfigDescriptor :: ConfigDescriptor , pluginNotificationHandlers :: PluginNotificationHandlers ideState + , pluginModifyDynflags :: DynFlagsModifications } -- | An existential wrapper of 'Properties' @@ -297,6 +323,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..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 @@ -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