Add warnings for file header pragmas that appear in the body of a module (#20385)

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

11 files changed, 73 insertions, 21 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 ceb4fa0ae0..02ca6a4b57 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 8a185bf4ec..61fc86c836 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 17090615f8..bf74bac0ab 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3257,6 +3257,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,
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index e69aabc0db..3e83958c88 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -107,6 +107,8 @@ instance Diagnostic PsMessage where
           $$ text "deprecated in the future."
     PsWarnUnrecognisedPragma
       -> mkSimpleDecorated $ text "Unrecognised pragma"
+    PsWarnMisplacedPragma prag
+      -> mkSimpleDecorated $ text "Misplaced" <+> pprFileHeaderPragmaType prag <+> text "pragma"
     PsWarnImportPreQualified
       -> mkSimpleDecorated $
             text "Found" <+> quotes (text "qualified")
@@ -506,6 +508,7 @@ instance Diagnostic PsMessage where
     PsWarnStarBinder                              -> WarningWithFlag Opt_WarnStarBinder
     PsWarnStarIsType                              -> WarningWithFlag Opt_WarnStarIsType
     PsWarnUnrecognisedPragma                      -> WarningWithFlag Opt_WarnUnrecognisedPragmas
+    PsWarnMisplacedPragma{}                       -> WarningWithFlag Opt_WarnMisplacedPragmas
     PsWarnImportPreQualified                      -> WarningWithFlag Opt_WarnPrepositiveQualifiedModule
     PsErrLexer{}                                  -> ErrorWithoutFlag
     PsErrCmmLexer                                 -> ErrorWithoutFlag
@@ -621,6 +624,7 @@ instance Diagnostic PsMessage where
     PsWarnStarBinder                              -> [SuggestQualifyStarOperator]
     PsWarnStarIsType                              -> [SuggestUseTypeFromDataKind Nothing]
     PsWarnUnrecognisedPragma                      -> noHints
+    PsWarnMisplacedPragma{}                       -> [SuggestPlacePragmaInHeader]
     PsWarnImportPreQualified                      -> [ SuggestQualifiedAfterModuleName
                                                      , suggestExtension LangExt.ImportQualifiedPost]
     PsErrLexer{}                                  -> noHints
@@ -835,3 +839,9 @@ parse_error_in_pat = text "Parse error in pattern:"
 forallSym :: Bool -> SDoc
 forallSym True  = text "∀"
 forallSym False = text "forall"
+
+pprFileHeaderPragmaType :: FileHeaderPragmaType -> SDoc
+pprFileHeaderPragmaType OptionsPrag    = text "OPTIONS"
+pprFileHeaderPragmaType IncludePrag    = text "INCLUDE"
+pprFileHeaderPragmaType LanguagePrag   = text "LANGUAGE"
+pprFileHeaderPragmaType DocOptionsPrag = text "OPTIONS_HADDOCK"
diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs
index f9a1b4661d..d2ff9c242d 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -119,6 +119,7 @@ data PsMessage
 
    -- | Unrecognised pragma
    | PsWarnUnrecognisedPragma
+   | PsWarnMisplacedPragma !FileHeaderPragmaType
 
    -- | Invalid Haddock comment position
    | PsWarnHaddockInvalidPos
@@ -550,3 +551,10 @@ data CmmParserError
 data TransLayoutReason
    = TransLayout_Where -- ^ "`where' clause at the same depth as implicit layout block"
    | TransLayout_Pipe  -- ^ "`|' at the same depth as implicit layout block")
+
+
+data FileHeaderPragmaType
+  = OptionsPrag
+  | IncludePrag
+  | LanguagePrag
+  | DocOptionsPrag
diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs
index 87f20b5c9c..2a31d21cfc 100644
--- a/compiler/GHC/Parser/Header.hs
+++ b/compiler/GHC/Parser/Header.hs
@@ -22,6 +22,8 @@ where
 
 import GHC.Prelude
 
+import GHC.Data.Bag
+
 import GHC.Driver.Errors.Types -- Unfortunate, needed due to the fact we throw exceptions!
 
 import GHC.Parser.Errors.Types
@@ -163,15 +165,17 @@ mkPrelImports this_mod loc implicit_prelude import_decls
 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
 getOptionsFromFile :: ParserOpts
                    -> FilePath            -- ^ Input file
-                   -> IO [Located String] -- ^ Parsed options, if any.
+                   -> IO (Messages PsMessage, [Located String]) -- ^ Parsed options, if any.
 getOptionsFromFile opts filename
     = Exception.bracket
               (openBinaryFile filename ReadMode)
               (hClose)
               (\handle -> do
-                  opts <- fmap (getOptions' opts)
+                  (warns, opts) <- fmap (getOptions' opts)
                                (lazyGetToks opts' filename handle)
-                  seqList opts $ return opts)
+                  seqList opts
+                    $ seqList (bagToList $ getMessages warns)
+                    $ return (warns, opts))
     where -- We don't need to get haddock doc tokens when we're just
           -- getting the options from pragmas, and lazily lexing them
           -- correctly is a little tricky: If there is "\n" or "\n-"
@@ -243,7 +247,7 @@ getToks popts filename buf = lexAll pstate
 getOptions :: ParserOpts
            -> StringBuffer -- ^ Input Buffer
            -> FilePath     -- ^ Source filename.  Used for location info.
-           -> [Located String] -- ^ Parsed options.
+           -> (Messages PsMessage,[Located String]) -- ^ warnings and parsed options.
 getOptions opts buf filename
     = getOptions' opts (getToks opts filename buf)
 
@@ -253,7 +257,7 @@ getOptions opts buf filename
 -- CPP, so we can't use the same trick as 'getImports'.
 getOptions' :: ParserOpts
             -> [Located Token]      -- Input buffer
-            -> [Located String]     -- Options.
+            -> (Messages PsMessage,[Located String])     -- Options.
 getOptions' opts toks
     = parseToks toks
     where
@@ -263,7 +267,7 @@ getOptions' opts toks
               = case toArgs starting_loc str of
                   Left _err -> optionsParseError str $   -- #15053
                                  combineSrcSpans (getLoc open) (getLoc close)
-                  Right args -> args ++ parseToks xs
+                  Right args -> fmap (args ++) (parseToks xs)
             where
               src_span      = getLoc open
               real_src_span = expectJust "getOptions'" (srcSpanToRealSrcSpan src_span)
@@ -271,22 +275,24 @@ getOptions' opts toks
           parseToks (open:close:xs)
               | ITinclude_prag str <- unLoc open
               , ITclose_prag       <- unLoc close
-              = map (L (getLoc open)) ["-#include",removeSpaces str] ++
-                parseToks xs
+              = fmap (map (L (getLoc open)) ["-#include",removeSpaces str] ++)
+                     (parseToks xs)
           parseToks (open:close:xs)
               | ITdocOptions str _ <- unLoc open
               , ITclose_prag       <- unLoc close
-              = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
-                ++ parseToks xs
+              = fmap (map (L (getLoc open)) ["-haddock-opts", removeSpaces str] ++)
+                     (parseToks xs)
           parseToks (open:xs)
               | ITlanguage_prag <- unLoc open
               = parseLanguage xs
           parseToks (comment:xs) -- Skip over comments
               | isComment (unLoc comment)
               = parseToks xs
-          parseToks _ = []
+          -- At the end of the header, warn about all the misplaced pragmas
+          parseToks xs = (unionManyMessages $ mapMaybe mkMessage xs ,[])
+
           parseLanguage ((L loc (ITconid fs)):rest)
-              = checkExtension opts (L loc fs) :
+              = fmap (checkExtension opts (L loc fs) :) $
                 case rest of
                   (L _loc ITcomma):more -> parseLanguage more
                   (L _loc ITclose_prag):more -> parseToks more
@@ -297,6 +303,20 @@ getOptions' opts toks
           parseLanguage []
               = panic "getOptions'.parseLanguage(2) went past eof token"
 
+          -- Warn for all the misplaced pragmas
+          mkMessage :: Located Token -> Maybe (Messages PsMessage)
+          mkMessage (L loc token)
+            | IToptions_prag _ <- token
+            = Just (singleMessage $ mkPlainMsgEnvelope diag_opts loc (PsWarnMisplacedPragma OptionsPrag))
+            | ITinclude_prag _ <- token
+            = Just (singleMessage $ mkPlainMsgEnvelope diag_opts loc (PsWarnMisplacedPragma IncludePrag))
+            | ITdocOptions _ _ <- token
+            = Just (singleMessage $ mkPlainMsgEnvelope diag_opts loc (PsWarnMisplacedPragma DocOptionsPrag))
+            | ITlanguage_prag <- token
+            = Just (singleMessage $ mkPlainMsgEnvelope diag_opts loc (PsWarnMisplacedPragma LanguagePrag))
+            | otherwise = Nothing
+            where diag_opts = pDiagOpts opts
+
           isComment :: Token -> Bool
           isComment c =
             case c of
diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs
index a3b40dbf2f..cbdb8d5321 100644
--- a/compiler/GHC/Types/Hint.hs
+++ b/compiler/GHC/Types/Hint.hs
@@ -394,6 +394,11 @@ data GhcHint
     -}
   | SuggestImportingDataCon
 
+  {- Found a pragma in the body of a module, suggest
+     placing it in the header
+  -}
+  | SuggestPlacePragmaInHeader
+
 -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated
 -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way
 -- to instantiate a particular signature, where the first argument is
diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs
index ee1060f0ff..fbaa2a8842 100644
--- a/compiler/GHC/Types/Hint/Ppr.hs
+++ b/compiler/GHC/Types/Hint/Ppr.hs
@@ -194,6 +194,9 @@ instance Outputable GhcHint where
       -> pprImportSuggestion import_suggestion
     SuggestImportingDataCon
       -> text "Import the data constructor to bring it into scope"
+    SuggestPlacePragmaInHeader
+      -> text "Perhaps you meant to place it in the module header?"
+      $$ text "The module header is the section at the top of the file, before the" <+> quotes (text "module") <+> text "keyword"
 
 perhapsAsPat :: SDoc
 perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"