Skip to content

Commit bb99905

Browse files
isovectorpepeiborramergify[bot]
authored
Add a hook for modifying the dynflags from a plugin (#1814)
* Add a hook for modifying the dynflags from a plugin * Tidy * Reset ModSummary * Put the DynFlagsModifications in IdeOptions * Add Haddock * Keep the old optModifyDynFlags * Update ghcide/src/Development/IDE/Core/Rules.hs Co-authored-by: Pepe Iborra <[email protected]> * Update ghcide/src/Development/IDE/Core/Rules.hs Co-authored-by: Pepe Iborra <[email protected]> Co-authored-by: Pepe Iborra <[email protected]> Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
1 parent 4e95b99 commit bb99905

File tree

12 files changed

+101
-43
lines changed

12 files changed

+101
-43
lines changed

‎ghcide/session-loader/Development/IDE/Session.hs

Lines changed: 3 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -84,10 +84,10 @@ import Control.Concurrent.STM (atomically)
8484
import Control.Concurrent.STM.TQueue
8585
import qualified Data.HashSet as Set
8686
import Database.SQLite.Simple
87-
import GHC.LanguageExtensions (Extension (EmptyCase))
8887
import HieDb.Create
8988
import HieDb.Types
9089
import HieDb.Utils
90+
import Ide.Types (dynFlagsModifyGlobal)
9191

9292
-- | Bump this version number when making changes to the format of the data stored in hiedb
9393
hiedbDataVersion :: String
@@ -256,7 +256,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
256256

257257
IdeOptions{ optTesting = IdeTesting optTesting
258258
, optCheckProject = getCheckProject
259-
, optCustomDynFlags
259+
, optModifyDynFlags
260260
, optExtensions
261261
} <- getIdeOptions
262262

@@ -287,7 +287,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
287287
-- Parse DynFlags for the newly discovered component
288288
hscEnv <- emptyHscEnv ideNc libDir
289289
(df, targets) <- evalGhcEnv hscEnv $
290-
first optCustomDynFlags <$> setOptions opts (hsc_dflags hscEnv)
290+
first (dynFlagsModifyGlobal optModifyDynFlags) <$> setOptions opts (hsc_dflags hscEnv)
291291
let deps = componentDependencies opts ++ maybeToList hieYaml
292292
dep_info <- getDependencyInfo deps
293293
-- Now lookup to see whether we are combining with an existing HscEnv
@@ -794,7 +794,6 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do
794794
setIgnoreInterfacePragmas $
795795
setLinkerOptions $
796796
disableOptimisation $
797-
allowEmptyCaseButWithWarning $
798797
setUpTypedHoles $
799798
makeDynFlagsAbsolute compRoot dflags'
800799
-- initPackages parses the -package flags and
@@ -803,15 +802,6 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do
803802
(final_df, _) <- liftIO $ wrapPackageSetupException $ initPackages dflags''
804803
return (final_df, targets)
805804

806-
807-
-- | Wingman wants to support destructing of empty cases, but these are a parse
808-
-- error by default. So we want to enable 'EmptyCase', but then that leads to
809-
-- silent errors without 'Opt_WarnIncompletePatterns'.
810-
allowEmptyCaseButWithWarning :: DynFlags -> DynFlags
811-
allowEmptyCaseButWithWarning =
812-
flip xopt_set EmptyCase . flip wopt_set Opt_WarnIncompletePatterns
813-
814-
815805
-- we don't want to generate object code so we compile to bytecode
816806
-- (HscInterpreted) which implies LinkInMemory
817807
-- HscInterpreted

‎ghcide/src/Development/IDE/Core/Rules.hs

Lines changed: 19 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -111,7 +111,7 @@ import Development.IDE.GHC.Compat hiding
111111
writeHieFile)
112112
import Development.IDE.GHC.Error
113113
import Development.IDE.GHC.ExactPrint
114-
import Development.IDE.GHC.Util
114+
import Development.IDE.GHC.Util hiding (modifyDynFlags)
115115
import Development.IDE.Import.DependencyInformation
116116
import Development.IDE.Import.FindImports
117117
import qualified Development.IDE.Spans.AtPoint as AtPoint
@@ -141,7 +141,7 @@ import System.Directory (canonicalizePath)
141141
import TcRnMonad (tcg_dependent_files)
142142

143143
import Ide.Plugin.Properties (HasProperty, KeyNameProxy, Properties, ToHsType, useProperty)
144-
import Ide.Types (PluginId)
144+
import Ide.Types (PluginId, DynFlagsModifications(dynFlagsModifyGlobal, dynFlagsModifyParser))
145145
import Data.Default (def)
146146
import Ide.PluginUtils (configForPlugin)
147147
import Control.Applicative
@@ -202,18 +202,21 @@ getParsedModuleRule :: Rules ()
202202
getParsedModuleRule =
203203
-- this rule does not have early cutoff since all its dependencies already have it
204204
define $ \GetParsedModule file -> do
205-
ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary file
205+
ModSummaryResult{msrModSummary = ms'} <- use_ GetModSummary file
206206
sess <- use_ GhcSession file
207207
let hsc = hscEnv sess
208208
opt <- getIdeOptions
209+
modify_dflags <- getModifyDynFlags dynFlagsModifyParser
210+
let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' }
209211

210212
let dflags = ms_hspp_opts ms
211213
mainParse = getParsedModuleDefinition hsc opt file ms
214+
reset_ms pm = pm { pm_mod_summary = ms' }
212215

213216
-- Parse again (if necessary) to capture Haddock parse errors
214217
res@(_,pmod) <- if gopt Opt_Haddock dflags
215218
then
216-
liftIO mainParse
219+
liftIO $ (fmap.fmap.fmap) reset_ms mainParse
217220
else do
218221
let haddockParse = getParsedModuleDefinition hsc opt file (withOptHaddock ms)
219222

@@ -223,7 +226,7 @@ getParsedModuleRule =
223226
-- If we can parse Haddocks, might as well use them
224227
--
225228
-- HLINT INTEGRATION: might need to save the other parsed module too
226-
((diags,res),(diagsh,resh)) <- liftIO $ concurrently mainParse haddockParse
229+
((diags,res),(diagsh,resh)) <- liftIO $ (fmap.fmap.fmap.fmap) reset_ms $ concurrently mainParse haddockParse
227230

228231
-- Merge haddock and regular diagnostics so we can always report haddock
229232
-- parse errors
@@ -275,8 +278,15 @@ getParsedModuleWithCommentsRule =
275278
opt <- getIdeOptions
276279

277280
let ms' = withoutOption Opt_Haddock $ withOption Opt_KeepRawTokenStream ms
281+
modify_dflags <- getModifyDynFlags dynFlagsModifyParser
282+
let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' }
283+
reset_ms pm = pm { pm_mod_summary = ms' }
284+
285+
liftIO $ fmap (fmap reset_ms) $ snd <$> getParsedModuleDefinition (hscEnv sess) opt file ms
286+
287+
getModifyDynFlags :: (DynFlagsModifications -> a) -> Action a
288+
getModifyDynFlags f = f . optModifyDynFlags <$> getIdeOptions
278289

279-
liftIO $ snd <$> getParsedModuleDefinition (hscEnv sess) opt file ms'
280290

281291
getParsedModuleDefinition
282292
:: HscEnv
@@ -775,7 +785,9 @@ isHiFileStableRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsHiFileStable f -
775785
getModSummaryRule :: Rules ()
776786
getModSummaryRule = do
777787
defineEarlyCutoff $ Rule $ \GetModSummary f -> do
778-
session <- hscEnv <$> use_ GhcSession f
788+
session' <- hscEnv <$> use_ GhcSession f
789+
modify_dflags <- getModifyDynFlags dynFlagsModifyGlobal
790+
let session = session' { hsc_dflags = modify_dflags $ hsc_dflags session' }
779791
(modTime, mFileContent) <- getFileContents f
780792
let fp = fromNormalizedFilePath f
781793
modS <- liftIO $ runExceptT $

‎ghcide/src/Development/IDE/Core/Service.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -21,9 +21,9 @@ module Development.IDE.Core.Service(
2121
import Development.IDE.Core.Debouncer
2222
import Development.IDE.Core.FileExists (fileExistsRules)
2323
import Development.IDE.Core.OfInterest
24+
import Development.IDE.Graph
2425
import Development.IDE.Types.Logger as Logger
2526
import Development.IDE.Types.Options (IdeOptions (..))
26-
import Development.IDE.Graph
2727
import Ide.Plugin.Config
2828
import qualified Language.LSP.Server as LSP
2929
import qualified Language.LSP.Types as LSP

‎ghcide/src/Development/IDE/Core/Shake.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -148,8 +148,8 @@ import Control.Exception.Extra hiding (bracket_)
148148
import Data.Default
149149
import HieDb.Types
150150
import Ide.Plugin.Config
151-
import qualified Ide.PluginUtils as HLS
152-
import Ide.Types (PluginId)
151+
import qualified Ide.PluginUtils as HLS
152+
import Ide.Types (PluginId)
153153

154154
-- | We need to serialize writes to the database, so we send any function that
155155
-- needs to write to the database over the channel, where it will be picked up by

‎ghcide/src/Development/IDE/Main.hs

Lines changed: 13 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -46,7 +46,7 @@ import Development.IDE.Core.Shake (IdeState (shakeExtras),
4646
import Development.IDE.Core.Tracing (measureMemory)
4747
import Development.IDE.Graph (action)
4848
import Development.IDE.LSP.LanguageServer (runLanguageServer)
49-
import Development.IDE.Plugin (Plugin (pluginHandlers, pluginRules))
49+
import Development.IDE.Plugin (Plugin (pluginHandlers, pluginRules, pluginModifyDynflags))
5050
import Development.IDE.Plugin.HLS (asGhcIdePlugin)
5151
import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide
5252
import Development.IDE.Session (SessionLoadingOptions,
@@ -60,7 +60,7 @@ import Development.IDE.Types.Logger (Logger (Logger))
6060
import Development.IDE.Types.Options (IdeGhcSession,
6161
IdeOptions (optCheckParents, optCheckProject, optReportProgress),
6262
clientSupportsProgress,
63-
defaultIdeOptions)
63+
defaultIdeOptions, optModifyDynFlags)
6464
import Development.IDE.Types.Shake (Key (Key))
6565
import GHC.IO.Encoding (setLocaleEncoding)
6666
import GHC.IO.Handle (hDuplicate)
@@ -216,8 +216,10 @@ defaultMain Arguments{..} = do
216216

217217
sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions $ fromMaybe dir rootPath
218218
config <- LSP.runLspT env LSP.getConfig
219-
let options = (argsIdeOptions config sessionLoader)
219+
let def_options = argsIdeOptions config sessionLoader
220+
options = def_options
220221
{ optReportProgress = clientSupportsProgress caps
222+
, optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
221223
}
222224
caps = LSP.resClientCapabilities env
223225
initialise
@@ -256,9 +258,11 @@ defaultMain Arguments{..} = do
256258
putStrLn "\nStep 3/4: Initializing the IDE"
257259
vfs <- makeVFSHandle
258260
sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir
259-
let options = (argsIdeOptions argsDefaultHlsConfig sessionLoader)
261+
let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader
262+
options = def_options
260263
{ optCheckParents = pure NeverCheck
261264
, optCheckProject = pure False
265+
, optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
262266
}
263267
ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan
264268
shakeSessionInit ide
@@ -304,10 +308,11 @@ defaultMain Arguments{..} = do
304308
runWithDb dbLoc $ \hiedb hieChan -> do
305309
vfs <- makeVFSHandle
306310
sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "."
307-
let options =
308-
(argsIdeOptions argsDefaultHlsConfig sessionLoader)
309-
{ optCheckParents = pure NeverCheck,
310-
optCheckProject = pure False
311+
let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader
312+
options = def_options
313+
{ optCheckParents = pure NeverCheck
314+
, optCheckProject = pure False
315+
, optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
311316
}
312317
ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan
313318
shakeSessionInit ide

‎ghcide/src/Development/IDE/Plugin.hs

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -4,18 +4,20 @@ import Data.Default
44
import Development.IDE.Graph
55

66
import Development.IDE.LSP.Server
7+
import Ide.Types (DynFlagsModifications)
78
import qualified Language.LSP.Server as LSP
89

910
data Plugin c = Plugin
1011
{pluginRules :: Rules ()
1112
,pluginHandlers :: LSP.Handlers (ServerM c)
13+
,pluginModifyDynflags :: DynFlagsModifications
1214
}
1315

1416
instance Default (Plugin c) where
15-
def = Plugin mempty mempty
17+
def = Plugin mempty mempty mempty
1618

1719
instance Semigroup (Plugin c) where
18-
Plugin x1 h1 <> Plugin x2 h2 = Plugin (x1<>x2) (h1 <> h2)
20+
Plugin x1 h1 d1 <> Plugin x2 h2 d2 = Plugin (x1<>x2) (h1 <> h2) (d1 <> d2)
1921

2022
instance Monoid (Plugin c) where
2123
mempty = def

‎ghcide/src/Development/IDE/Plugin/HLS.hs

Lines changed: 10 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ import Development.IDE.Core.Shake
2626
import Development.IDE.Core.Tracing
2727
import Development.IDE.LSP.Server
2828
import Development.IDE.Plugin
29+
import qualified Development.IDE.Plugin as P
2930
import Development.IDE.Types.Logger
3031
import Development.IDE.Graph (Rules)
3132
import Ide.Plugin.Config
@@ -48,7 +49,8 @@ asGhcIdePlugin (IdePlugins ls) =
4849
mkPlugin rulesPlugins HLS.pluginRules <>
4950
mkPlugin executeCommandPlugins HLS.pluginCommands <>
5051
mkPlugin extensiblePlugins HLS.pluginHandlers <>
51-
mkPlugin extensibleNotificationPlugins HLS.pluginNotificationHandlers
52+
mkPlugin extensibleNotificationPlugins HLS.pluginNotificationHandlers <>
53+
mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags
5254
where
5355

5456
mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> b) -> Plugin Config
@@ -63,14 +65,17 @@ asGhcIdePlugin (IdePlugins ls) =
6365
-- ---------------------------------------------------------------------
6466

6567
rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config
66-
rulesPlugins rs = Plugin rules mempty
68+
rulesPlugins rs = mempty { P.pluginRules = rules }
6769
where
6870
rules = foldMap snd rs
6971

72+
dynFlagsPlugins :: [(PluginId, DynFlagsModifications)] -> Plugin Config
73+
dynFlagsPlugins rs = mempty { P.pluginModifyDynflags = foldMap snd rs }
74+
7075
-- ---------------------------------------------------------------------
7176

7277
executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config
73-
executeCommandPlugins ecs = Plugin mempty (executeCommandHandlers ecs)
78+
executeCommandPlugins ecs = mempty { P.pluginHandlers = executeCommandHandlers ecs }
7479

7580
executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config)
7681
executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd
@@ -132,7 +137,7 @@ executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd
132137
-- ---------------------------------------------------------------------
133138

134139
extensiblePlugins :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config
135-
extensiblePlugins xs = Plugin mempty handlers
140+
extensiblePlugins xs = mempty { P.pluginHandlers = handlers }
136141
where
137142
IdeHandlers handlers' = foldMap bakePluginId xs
138143
bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers
@@ -160,7 +165,7 @@ extensiblePlugins xs = Plugin mempty handlers
160165
-- ---------------------------------------------------------------------
161166

162167
extensibleNotificationPlugins :: [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config
163-
extensibleNotificationPlugins xs = Plugin mempty handlers
168+
extensibleNotificationPlugins xs = mempty { P.pluginHandlers = handlers }
164169
where
165170
IdeNotificationHandlers handlers' = foldMap bakePluginId xs
166171
bakePluginId :: (PluginId, PluginNotificationHandlers IdeState) -> IdeNotificationHandlers

‎ghcide/src/Development/IDE/Plugin/Test.hs

Lines changed: 5 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,8 @@ import Ide.Types
3737
import qualified Language.LSP.Server as LSP
3838
import Language.LSP.Types
3939
import System.Time.Extra
40+
import qualified Development.IDE.Plugin as P
41+
import Data.Default (def)
4042

4143
data TestRequest
4244
= BlockSeconds Seconds -- ^ :: Null
@@ -51,9 +53,9 @@ newtype WaitForIdeRuleResult = WaitForIdeRuleResult { ideResultSuccess::Bool}
5153
deriving newtype (FromJSON, ToJSON)
5254

5355
plugin :: Plugin c
54-
plugin = Plugin {
55-
pluginRules = return (),
56-
pluginHandlers = requestHandler (SCustomMethod "test") testRequestHandler'
56+
plugin = def {
57+
P.pluginRules = return (),
58+
P.pluginHandlers = requestHandler (SCustomMethod "test") testRequestHandler'
5759
}
5860
where
5961
testRequestHandler' ide req

‎ghcide/src/Development/IDE/Types/Options.hs

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ import GHC hiding (parseModule,
2828
typecheckModule)
2929
import GhcPlugins as GHC hiding (fst3, (<>))
3030
import Ide.Plugin.Config
31+
import Ide.Types (DynFlagsModifications)
3132
import qualified Language.LSP.Types.Capabilities as LSP
3233

3334
data IdeOptions = IdeOptions
@@ -73,7 +74,7 @@ data IdeOptions = IdeOptions
7374
-- Otherwise, return the result of parsing without Opt_Haddock, so
7475
-- that the parsed module contains the result of Opt_KeepRawTokenStream,
7576
-- which might be necessary for hlint.
76-
, optCustomDynFlags :: DynFlags -> DynFlags
77+
, optModifyDynFlags :: DynFlagsModifications
7778
-- ^ Will be called right after setting up a new cradle,
7879
-- allowing to customize the Ghc options used
7980
, optShakeOptions :: ShakeOptions
@@ -138,7 +139,7 @@ defaultIdeOptions session = IdeOptions
138139
,optCheckProject = pure True
139140
,optCheckParents = pure CheckOnSaveAndClose
140141
,optHaddockParse = HaddockParse
141-
,optCustomDynFlags = id
142+
,optModifyDynFlags = mempty
142143
,optSkipProgress = defaultSkipProgress
143144
,optProgressStyle = Explicit
144145
}

‎hls-plugin-api/hls-plugin-api.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -43,6 +43,7 @@ library
4343
, dependent-sum
4444
, Diff ^>=0.4.0
4545
, dlist
46+
, ghc
4647
, hashable
4748
, hslogger
4849
, lens

0 commit comments

Comments
 (0)