Skip to content

Commit 7ef8f4f

Browse files
isovectorisovector
committed
Add a hook for modifying the dynflags from a plugin
1 parent 1e47c75 commit 7ef8f4f

File tree

11 files changed

+82
-33
lines changed

11 files changed

+82
-33
lines changed

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

Lines changed: 0 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -84,7 +84,6 @@ 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
@@ -794,7 +793,6 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do
794793
setIgnoreInterfacePragmas $
795794
setLinkerOptions $
796795
disableOptimisation $
797-
allowEmptyCaseButWithWarning $
798796
setUpTypedHoles $
799797
makeDynFlagsAbsolute compRoot dflags'
800798
-- initPackages parses the -package flags and
@@ -803,15 +801,6 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do
803801
(final_df, _) <- liftIO $ wrapPackageSetupException $ initPackages dflags''
804802
return (final_df, targets)
805803

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-
815804
-- we don't want to generate object code so we compile to bytecode
816805
-- (HscInterpreted) which implies LinkInMemory
817806
-- HscInterpreted

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

Lines changed: 15 additions & 5 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
@@ -140,7 +140,7 @@ import Module
140140
import TcRnMonad (tcg_dependent_files)
141141

142142
import Ide.Plugin.Properties (HasProperty, KeyNameProxy, Properties, ToHsType, useProperty)
143-
import Ide.Types (PluginId)
143+
import Ide.Types (PluginId, DynFlagsModifications(dynFlagsModifyGlobal, dynFlagsModifyParser))
144144
import Data.Default (def)
145145
import Ide.PluginUtils (configForPlugin)
146146
import Control.Applicative
@@ -211,10 +211,12 @@ getParsedModuleRule :: Rules ()
211211
getParsedModuleRule =
212212
-- this rule does not have early cutoff since all its dependencies already have it
213213
define $ \GetParsedModule file -> do
214-
ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary file
214+
ModSummaryResult{msrModSummary = ms'} <- use_ GetModSummary file
215215
sess <- use_ GhcSession file
216216
let hsc = hscEnv sess
217217
opt <- getIdeOptions
218+
modify_dflags <- getModifyDynFlags id dynFlagsModifyParser
219+
let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' }
218220

219221
let dflags = ms_hspp_opts ms
220222
mainParse = getParsedModuleDefinition hsc opt file ms
@@ -284,8 +286,14 @@ getParsedModuleWithCommentsRule =
284286
opt <- getIdeOptions
285287

286288
let ms' = withoutOption Opt_Haddock $ withOption Opt_KeepRawTokenStream ms
289+
modify_dflags <- getModifyDynFlags id dynFlagsModifyParser
290+
let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' }
291+
292+
liftIO $ snd <$> getParsedModuleDefinition (hscEnv sess) opt file ms
293+
294+
getModifyDynFlags :: a -> (DynFlagsModifications -> a) -> Action a
295+
getModifyDynFlags a f = maybe a (f . dynFlagsMods) <$> getShakeExtra
287296

288-
liftIO $ snd <$> getParsedModuleDefinition (hscEnv sess) opt file ms'
289297

290298
getParsedModuleDefinition
291299
:: HscEnv
@@ -782,7 +790,9 @@ isHiFileStableRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsHiFileStable f -
782790
getModSummaryRule :: Rules ()
783791
getModSummaryRule = do
784792
defineEarlyCutoff $ Rule $ \GetModSummary f -> do
785-
session <- hscEnv <$> use_ GhcSession f
793+
session' <- hscEnv <$> use_ GhcSession f
794+
modify_dflags <- getModifyDynFlags id dynFlagsModifyGlobal
795+
let session = session' { hsc_dflags = modify_dflags $ hsc_dflags session' }
786796
(modTime, mFileContent) <- getFileContents f
787797
let fp = fromNormalizedFilePath f
788798
modS <- liftIO $ runExceptT $

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

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,8 @@ import qualified Language.LSP.Types as LSP
3030

3131
import Control.Monad
3232
import Development.IDE.Core.Shake
33+
import Development.IDE.GHC.Compat (DynFlags)
34+
import Ide.Types (DynFlagsModifications)
3335

3436

3537
------------------------------------------------------------
@@ -38,6 +40,7 @@ import Development.IDE.Core.Shake
3840
-- | Initialise the Compiler Service.
3941
initialise :: Config
4042
-> Rules ()
43+
-> DynFlagsModifications
4144
-> Maybe (LSP.LanguageContextEnv Config)
4245
-> Logger
4346
-> Debouncer LSP.NormalizedUri
@@ -46,10 +49,11 @@ initialise :: Config
4649
-> HieDb
4750
-> IndexQueue
4851
-> IO IdeState
49-
initialise defaultConfig mainRule lspEnv logger debouncer options vfs hiedb hiedbChan =
52+
initialise defaultConfig mainRule dynFlagsMods lspEnv logger debouncer options vfs hiedb hiedbChan =
5053
shakeOpen
5154
lspEnv
5255
defaultConfig
56+
dynFlagsMods
5357
logger
5458
debouncer
5559
(optShakeProfiling options)

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

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -147,8 +147,9 @@ import Control.Exception.Extra hiding (bracket_)
147147
import Data.Default
148148
import HieDb.Types
149149
import Ide.Plugin.Config
150-
import qualified Ide.PluginUtils as HLS
151-
import Ide.Types (PluginId)
150+
import qualified Ide.PluginUtils as HLS
151+
import Ide.Types (PluginId, DynFlagsModifications)
152+
import DynFlags (DynFlags)
152153

153154
-- | We need to serialize writes to the database, so we send any function that
154155
-- needs to write to the database over the channel, where it will be picked up by
@@ -171,6 +172,7 @@ data ShakeExtras = ShakeExtras
171172
lspEnv :: Maybe (LSP.LanguageContextEnv Config)
172173
,debouncer :: Debouncer NormalizedUri
173174
,logger :: Logger
175+
,dynFlagsMods :: DynFlagsModifications
174176
,globals :: Var (HMap.HashMap TypeRep Dynamic)
175177
,state :: Var Values
176178
,diagnostics :: Var DiagnosticStore
@@ -454,6 +456,7 @@ seqValue v b = case v of
454456
-- | Open a 'IdeState', should be shut using 'shakeShut'.
455457
shakeOpen :: Maybe (LSP.LanguageContextEnv Config)
456458
-> Config
459+
-> DynFlagsModifications
457460
-> Logger
458461
-> Debouncer NormalizedUri
459462
-> Maybe FilePath
@@ -465,7 +468,7 @@ shakeOpen :: Maybe (LSP.LanguageContextEnv Config)
465468
-> ShakeOptions
466469
-> Rules ()
467470
-> IO IdeState
468-
shakeOpen lspEnv defaultConfig logger debouncer
471+
shakeOpen lspEnv defaultConfig dynFlagsMods logger debouncer
469472
shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo
470473

471474
us <- mkSplitUniqSupply 'r'

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

Lines changed: 4 additions & 3 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,
@@ -223,6 +223,7 @@ defaultMain Arguments{..} = do
223223
initialise
224224
argsDefaultHlsConfig
225225
rules
226+
(pluginModifyDynflags plugins)
226227
(Just env)
227228
logger
228229
debouncer
@@ -260,7 +261,7 @@ defaultMain Arguments{..} = do
260261
{ optCheckParents = pure NeverCheck
261262
, optCheckProject = pure False
262263
}
263-
ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan
264+
ide <- initialise argsDefaultHlsConfig rules (pluginModifyDynflags plugins) Nothing logger debouncer options vfs hiedb hieChan
264265
shakeSessionInit ide
265266
registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
266267

@@ -309,7 +310,7 @@ defaultMain Arguments{..} = do
309310
{ optCheckParents = pure NeverCheck,
310311
optCheckProject = pure False
311312
}
312-
ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan
313+
ide <- initialise argsDefaultHlsConfig rules (pluginModifyDynflags plugins) Nothing logger debouncer options vfs hiedb hieChan
313314
shakeSessionInit ide
314315
registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
315316
c ide

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

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -5,17 +5,21 @@ import Development.IDE.Graph
55

66
import Development.IDE.LSP.Server
77
import qualified Language.LSP.Server as LSP
8+
import Development.IDE.GHC.Compat (DynFlags)
9+
import Data.Monoid (Endo)
10+
import Ide.Types (DynFlagsModifications)
811

912
data Plugin c = Plugin
1013
{pluginRules :: Rules ()
1114
,pluginHandlers :: LSP.Handlers (ServerM c)
15+
,pluginModifyDynflags :: DynFlagsModifications
1216
}
1317

1418
instance Default (Plugin c) where
15-
def = Plugin mempty mempty
19+
def = Plugin mempty mempty mempty
1620

1721
instance Semigroup (Plugin c) where
18-
Plugin x1 h1 <> Plugin x2 h2 = Plugin (x1<>x2) (h1 <> h2)
22+
Plugin x1 h1 d1 <> Plugin x2 h2 d2 = Plugin (x1<>x2) (h1 <> h2) (d1 <> d2)
1923

2024
instance Monoid (Plugin c) where
2125
mempty = def

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

Lines changed: 11 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
@@ -38,6 +39,7 @@ import Text.Regex.TDFA.Text ()
3839
import UnliftIO (MonadUnliftIO)
3940
import UnliftIO.Async (forConcurrently)
4041
import UnliftIO.Exception (catchAny)
42+
import Development.IDE.GHC.Compat (DynFlags)
4143

4244
-- ---------------------------------------------------------------------
4345
--
@@ -48,7 +50,8 @@ asGhcIdePlugin (IdePlugins ls) =
4850
mkPlugin rulesPlugins HLS.pluginRules <>
4951
mkPlugin executeCommandPlugins HLS.pluginCommands <>
5052
mkPlugin extensiblePlugins HLS.pluginHandlers <>
51-
mkPlugin extensibleNotificationPlugins HLS.pluginNotificationHandlers
53+
mkPlugin extensibleNotificationPlugins HLS.pluginNotificationHandlers <>
54+
mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags
5255
where
5356

5457
mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> b) -> Plugin Config
@@ -63,14 +66,17 @@ asGhcIdePlugin (IdePlugins ls) =
6366
-- ---------------------------------------------------------------------
6467

6568
rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config
66-
rulesPlugins rs = Plugin rules mempty
69+
rulesPlugins rs = mempty { P.pluginRules = rules }
6770
where
6871
rules = foldMap snd rs
6972

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

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

7581
executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config)
7682
executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd
@@ -132,7 +138,7 @@ executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd
132138
-- ---------------------------------------------------------------------
133139

134140
extensiblePlugins :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config
135-
extensiblePlugins xs = Plugin mempty handlers
141+
extensiblePlugins xs = mempty { P.pluginHandlers = handlers }
136142
where
137143
IdeHandlers handlers' = foldMap bakePluginId xs
138144
bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers
@@ -160,7 +166,7 @@ extensiblePlugins xs = Plugin mempty handlers
160166
-- ---------------------------------------------------------------------
161167

162168
extensibleNotificationPlugins :: [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config
163-
extensibleNotificationPlugins xs = Plugin mempty handlers
169+
extensibleNotificationPlugins xs = mempty { P.pluginHandlers = handlers }
164170
where
165171
IdeNotificationHandlers handlers' = foldMap bakePluginId xs
166172
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

‎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

‎hls-plugin-api/src/Ide/Types.hs

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -50,12 +50,26 @@ import Language.LSP.VFS
5050
import OpenTelemetry.Eventlog
5151
import System.IO.Unsafe
5252
import Text.Regex.TDFA.Text ()
53+
import DynFlags (DynFlags)
5354

5455
-- ---------------------------------------------------------------------
5556

5657
newtype IdePlugins ideState = IdePlugins
5758
{ ipMap :: [(PluginId, PluginDescriptor ideState)]}
5859

60+
data DynFlagsModifications =
61+
DynFlagsModifications { dynFlagsModifyGlobal :: DynFlags -> DynFlags
62+
, dynFlagsModifyParser :: DynFlags -> DynFlags
63+
}
64+
65+
instance Semigroup DynFlagsModifications where
66+
DynFlagsModifications g1 p1 <> DynFlagsModifications g2 p2 =
67+
DynFlagsModifications (g2 . g1) (p2 . p1)
68+
69+
instance Monoid DynFlagsModifications where
70+
mempty = DynFlagsModifications id id
71+
72+
5973
-- ---------------------------------------------------------------------
6074

6175
data PluginDescriptor ideState =
@@ -65,6 +79,7 @@ data PluginDescriptor ideState =
6579
, pluginHandlers :: PluginHandlers ideState
6680
, pluginConfigDescriptor :: ConfigDescriptor
6781
, pluginNotificationHandlers :: PluginNotificationHandlers ideState
82+
, pluginModifyDynflags :: DynFlagsModifications
6883
}
6984

7085
-- | An existential wrapper of 'Properties'
@@ -297,6 +312,7 @@ defaultPluginDescriptor plId =
297312
mempty
298313
defaultConfigDescriptor
299314
mempty
315+
mempty
300316

301317
newtype CommandId = CommandId T.Text
302318
deriving (Show, Read, Eq, Ord)

‎plugins/hls-tactics-plugin/src/Wingman/Plugin.hs

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,7 @@ import Wingman.Machinery (scoreSolution)
3737
import Wingman.Range
3838
import Wingman.Tactics
3939
import Wingman.Types
40+
import GHC.LanguageExtensions.Type (Extension(EmptyCase))
4041

4142

4243
descriptor :: PluginId -> PluginDescriptor IdeState
@@ -62,9 +63,21 @@ descriptor plId = (defaultPluginDescriptor plId)
6263
, pluginRules = wingmanRules plId
6364
, pluginConfigDescriptor =
6465
defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}
66+
, pluginModifyDynflags = mempty
67+
{ dynFlagsModifyGlobal = allowEmptyCaseButWithWarning
68+
}
6569
}
6670

6771

72+
-- | Wingman wants to support destructing of empty cases, but these are a parse
73+
-- error by default. So we want to enable 'EmptyCase', but then that leads to
74+
-- silent errors without 'Opt_WarnIncompletePatterns'.
75+
allowEmptyCaseButWithWarning :: DynFlags -> DynFlags
76+
allowEmptyCaseButWithWarning =
77+
flip xopt_set EmptyCase . flip wopt_set Opt_WarnIncompletePatterns
78+
79+
80+
6881
codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction
6982
codeActionProvider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) (unsafeMkCurrent -> range) _ctx)
7083
| Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do

0 commit comments

Comments
 (0)