Add warnings for file header pragmas that appear in the body of a module (#20385)wip/parse-errs

Once we are done parsing the header of a module to obtain the options, we
look through the rest of the tokens in order to determine if they contain any
misplaced file header pragmas that would usually be ignored, potentially
resulting in bad error messages.

The warnings are reported immediately so that later errors don't shadow
over potentially helpful warnings.

Metric Increase:
  T13719

6 files changed, 15 insertions, 9 deletions

diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 43ced2ba13..9c67f1550b 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -97,7 +97,7 @@ doBackpack [src_filename] = do
     dflags0 <- getDynFlags
     let dflags1 = dflags0
     let parser_opts1 = initParserOpts dflags1
-    src_opts <- liftIO $ getOptionsFromFile parser_opts1 src_filename
+    (p_warns, src_opts) <- liftIO $ getOptionsFromFile parser_opts1 src_filename
     (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts
     modifySession (hscSetFlags dflags)
     logger <- getLogger -- Get the logger after having set the session flags,
@@ -105,6 +105,7 @@ doBackpack [src_filename] = do
                         -- Not doing so caused #20396.
     -- Cribbed from: preprocessFile / GHC.Driver.Pipeline
     liftIO $ checkProcessArgsResult unhandled_flags
+    liftIO $ printOrThrowDiagnostics logger (initDiagOpts dflags) (GhcPsMessage <$> p_warns)
     liftIO $ handleFlagWarnings logger (initDiagOpts dflags) warns
     -- TODO: Preprocessing not implemented
 
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index a2ac1b75f4..671d163ac7 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -503,6 +503,7 @@ data WarningFlag =
    | Opt_WarnIdentities
    | Opt_WarnTabs
    | Opt_WarnUnrecognisedPragmas
+   | Opt_WarnMisplacedPragmas
    | Opt_WarnDodgyForeignImports
    | Opt_WarnUnusedDoBind
    | Opt_WarnWrongDoBind
@@ -623,6 +624,7 @@ warnFlagNames wflag = case wflag of
   Opt_WarnTypedHoles                              -> "typed-holes" :| []
   Opt_WarnPartialTypeSignatures                   -> "partial-type-signatures" :| []
   Opt_WarnUnrecognisedPragmas                     -> "unrecognised-pragmas" :| []
+  Opt_WarnMisplacedPragmas                        -> "misplaced-pragmas" :| []
   Opt_WarnUnsafe                                  -> "unsafe" :| []
   Opt_WarnUnsupportedCallingConventions           -> "unsupported-calling-conventions" :| []
   Opt_WarnUnsupportedLlvmVersion                  -> "unsupported-llvm-version" :| []
@@ -731,6 +733,7 @@ standardWarnings -- see Note [Documenting warning flags]
         Opt_WarnDeferredOutOfScopeVariables,
         Opt_WarnPartialTypeSignatures,
         Opt_WarnUnrecognisedPragmas,
+        Opt_WarnMisplacedPragmas,
         Opt_WarnDuplicateExports,
         Opt_WarnDerivingDefaults,
         Opt_WarnOverflowedLiterals,
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 415bb5e38f..d8b9bfa8af 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -663,13 +663,13 @@ preprocessPipeline pipe_env hsc_env input_fn = do
       use (T_Unlit pipe_env hsc_env input_fn)
 
 
-  (dflags1, warns1) <- use (T_FileArgs hsc_env unlit_fn)
+  (dflags1, p_warns1, warns1) <- use (T_FileArgs hsc_env unlit_fn)
   let hsc_env1 = hscSetFlags dflags1 hsc_env
 
   (cpp_fn, hsc_env2)
     <- runAfterFlag hsc_env1 (Cpp HsSrcFile) (xopt LangExt.Cpp) (unlit_fn, hsc_env1) $ do
           cpp_fn <- use (T_Cpp pipe_env hsc_env1 unlit_fn)
-          (dflags2, _) <- use (T_FileArgs hsc_env1 cpp_fn)
+          (dflags2, _, _) <- use (T_FileArgs hsc_env1 cpp_fn)
           let hsc_env2 = hscSetFlags dflags2 hsc_env1
           return (cpp_fn, hsc_env2)
 
@@ -677,15 +677,16 @@ preprocessPipeline pipe_env hsc_env input_fn = do
   pp_fn <- runAfterFlag hsc_env2 (HsPp HsSrcFile) (gopt Opt_Pp) cpp_fn $
             use (T_HsPp pipe_env hsc_env2 input_fn cpp_fn)
 
-  (dflags3, warns3)
+  (dflags3, p_warns3, warns3)
     <- if pp_fn == unlit_fn
           -- Didn't run any preprocessors so don't need to reparse, would be nicer
           -- if `T_FileArgs` recognised this.
-          then return (dflags1, warns1)
+          then return (dflags1, p_warns1, warns1)
           else do
             -- Reparse with original hsc_env so that we don't get duplicated options
             use (T_FileArgs hsc_env pp_fn)
 
+  liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3))
   liftIO (handleFlagWarnings (hsc_logger hsc_env) (initDiagOpts dflags3) warns3)
   return (dflags3, pp_fn)
 
diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
index 97eeb58260..baf4071d51 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/compiler/GHC/Driver/Pipeline/Execute.hs
@@ -571,15 +571,15 @@ runUnlitPhase hsc_env input_fn output_fn = do
 
     return output_fn
 
-getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, [Warn]))
+getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, [Warn]))
 getFileArgs hsc_env input_fn = do
   let dflags0 = hsc_dflags hsc_env
       parser_opts = initParserOpts dflags0
-  src_opts <- getOptionsFromFile parser_opts input_fn
+  (warns0, src_opts) <- getOptionsFromFile parser_opts input_fn
   (dflags1, unhandled_flags, warns)
     <- parseDynamicFilePragma dflags0 src_opts
   checkProcessArgsResult unhandled_flags
-  return (dflags1, warns)
+  return (dflags1, warns0, warns)
 
 runCppPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath
 runCppPhase hsc_env input_fn output_fn = do
diff --git a/compiler/GHC/Driver/Pipeline/Phases.hs b/compiler/GHC/Driver/Pipeline/Phases.hs
index d689e1e266..431c9e0b1d 100644
--- a/compiler/GHC/Driver/Pipeline/Phases.hs
+++ b/compiler/GHC/Driver/Pipeline/Phases.hs
@@ -28,7 +28,7 @@ import GHC.Driver.Phases
 -- phase if the inputs have been modified.
 data TPhase res where
   T_Unlit :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
-  T_FileArgs :: HscEnv -> FilePath -> TPhase (DynFlags, [Warn])
+  T_FileArgs :: HscEnv -> FilePath -> TPhase (DynFlags, Messages PsMessage, [Warn])
   T_Cpp   :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
   T_HsPp  :: PipeEnv -> HscEnv -> FilePath -> FilePath -> TPhase FilePath
   T_HscRecomp :: PipeEnv -> HscEnv -> FilePath -> HscSource -> TPhase (HscEnv, ModSummary, HscRecompStatus)
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 0be53034f3..f03d175549 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3256,6 +3256,7 @@ wWarningFlagsDeps = mconcat [
   warnSpec    Opt_WarnTypedHoles,
   warnSpec    Opt_WarnPartialTypeSignatures,
   warnSpec    Opt_WarnUnrecognisedPragmas,
+  warnSpec    Opt_WarnMisplacedPragmas,
   warnSpec'   Opt_WarnUnsafe setWarnUnsafe,
   warnSpec    Opt_WarnUnsupportedCallingConventions,
   warnSpec    Opt_WarnUnsupportedLlvmVersion,