Add a hook for modifying the dynflags from a plugin

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

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,18 +211,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 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
+        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)
 
@@ -232,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
@@ -284,8 +287,15 @@ 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' }
+        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
 
-    liftIO $ snd <$> getParsedModuleDefinition (hscEnv sess) opt file ms'
 
 getParsedModuleDefinition
     :: HscEnv
@@ -782,7 +792,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 $

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

@@ -21,10 +21,11 @@ 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
 
@@ -38,6 +39,7 @@ import           Development.IDE.Core.Shake
 -- | Initialise the Compiler Service.
 initialise :: Config
            -> Rules ()
+           -> DynFlagsModifications
            -> Maybe (LSP.LanguageContextEnv Config)
            -> Logger
            -> Debouncer LSP.NormalizedUri
@@ -46,10 +48,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)

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

@@ -147,8 +147,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, DynFlagsModifications)
 
 -- | 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 +171,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 +455,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 +467,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'

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

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

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

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

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

@@ -43,6 +43,7 @@ library
     , dependent-sum
     , Diff                  ^>=0.4.0
     , dlist
+    , ghc
     , hashable
     , hslogger
     , lens

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,19 @@ import           Text.Regex.TDFA.Text            ()
 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)

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