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 <pepeiborra@me.com> * Update ghcide/src/Development/IDE/Core/Rules.hs Co-authored-by: Pepe Iborra <pepeiborra@me.com> Co-authored-by: Pepe Iborra <pepeiborra@me.com> Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
haskell · May 11, 2021 · bb99905 · bb99905
1 parent 4e95b99
commit bb99905
Show file tree

Hide file tree

Showing 12 changed files with 101 additions and 43 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -43,6 +43,7 @@ library
     , dependent-sum
     , Diff                  ^>=0.4.0
     , dlist
+    , ghc
     , hashable
     , hslogger
     , lens