summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Driver/Backpack.hs3
-rw-r--r--compiler/GHC/Driver/Flags.hs3
-rw-r--r--compiler/GHC/Driver/Pipeline.hs9
-rw-r--r--compiler/GHC/Driver/Pipeline/Execute.hs6
-rw-r--r--compiler/GHC/Driver/Pipeline/Phases.hs2
-rw-r--r--compiler/GHC/Driver/Session.hs1
-rw-r--r--compiler/GHC/Parser/Errors/Ppr.hs10
-rw-r--r--compiler/GHC/Parser/Errors/Types.hs8
-rw-r--r--compiler/GHC/Parser/Header.hs44
-rw-r--r--compiler/GHC/Types/Hint.hs5
-rw-r--r--compiler/GHC/Types/Hint/Ppr.hs3
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 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,
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index 4f649d9190..915fd1d4a7 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")
@@ -501,6 +503,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
@@ -615,6 +618,7 @@ instance Diagnostic PsMessage where
PsWarnStarBinder -> [SuggestQualifyStarOperator]
PsWarnStarIsType -> [SuggestUseTypeFromDataKind Nothing]
PsWarnUnrecognisedPragma -> noHints
+ PsWarnMisplacedPragma{} -> [SuggestPlacePragmaInHeader]
PsWarnImportPreQualified -> [ SuggestQualifiedAfterModuleName
, suggestExtension LangExt.ImportQualifiedPost]
PsErrLexer{} -> noHints
@@ -828,3 +832,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 d99f789154..2b7854f47e 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
@@ -547,3 +548,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 6304b1d7fd..b964b18914 100644
--- a/compiler/GHC/Types/Hint.hs
+++ b/compiler/GHC/Types/Hint.hs
@@ -391,6 +391,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 5ed31571b0..321c87d56b 100644
--- a/compiler/GHC/Types/Hint/Ppr.hs
+++ b/compiler/GHC/Types/Hint/Ppr.hs
@@ -181,6 +181,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"
View Lorry Controller Status