summaryrefslogtreecommitdiff
path: root/compiler/GHC/Parser
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Parser')
-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
3 files changed, 50 insertions, 12 deletions
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
View Lorry Controller Status