X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHeaderInfo.hs;h=93ce824964ba4e37e65e52095b479e3aea7c71a7;hp=89f4661fd958d42edc2b7b8bd25423ac04c02275;hb=b2bd63f99d643f6b3eb30bb72bb9ae26d4183252;hpb=c197fe602ed4aadf09affe0cdc18e7158d262012 diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 89f4661..93ce824 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -9,6 +9,7 @@ ----------------------------------------------------------------------------- module HeaderInfo ( getImports + , mkPrelImports -- used by the renamer too , getOptionsFromFile, getOptions , optionsErrorMsgs, checkProcessArgsResult ) where @@ -20,9 +21,9 @@ import HscTypes import Parser ( parseHeader ) import Lexer import FastString -import HsSyn ( ImportDecl(..), HsModule(..) ) -import Module ( ModuleName, moduleName ) -import PrelNames ( gHC_PRIM, mAIN_NAME ) +import HsSyn +import Module +import PrelNames import StringBuffer import SrcLoc import DynFlags @@ -32,9 +33,9 @@ import Outputable import Pretty () import Maybes import Bag ( emptyBag, listToBag, unitBag ) - -import MonadUtils ( MonadIO ) +import MonadUtils import Exception + import Control.Monad import System.IO import System.IO.Unsafe @@ -45,38 +46,74 @@ import Data.List -- | Parse the imports of a source file. -- -- Throws a 'SourceError' if parsing fails. -getImports :: GhcMonad m => - DynFlags +getImports :: DynFlags -> StringBuffer -- ^ Parse this. -> FilePath -- ^ Filename the buffer came from. Used for -- reporting parse error locations. -> FilePath -- ^ The original source filename (used for locations -- in the function result) - -> m ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName) + -> IO ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName) -- ^ The source imports, normal imports, and the module name. getImports dflags buf filename source_filename = do - let loc = mkSrcLoc (mkFastString filename) 1 0 - case unP parseHeader (mkPState buf loc dflags) of + let loc = mkRealSrcLoc (mkFastString filename) 1 1 + case unP parseHeader (mkPState dflags buf loc) of PFailed span err -> parseError span err POk pst rdr_module -> do - let ms@(warns, errs) = getMessages pst - logWarnings warns + let _ms@(_warns, errs) = getMessages pst + -- don't log warnings: they'll be reported when we parse the file + -- for real. See #2500. + ms = (emptyBag, errs) + -- logWarnings warns if errorsFound dflags ms - then liftIO $ throwIO $ mkSrcErr errs + then throwIO $ mkSrcErr errs else case rdr_module of - L _ (HsModule mb_mod _ imps _ _ _ _) -> + L _ (HsModule mb_mod _ imps _ _ _) -> let - main_loc = mkSrcLoc (mkFastString source_filename) 1 0 + main_loc = mkSrcLoc (mkFastString source_filename) 1 1 mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps + + -- GHC.Prim doesn't exist physically, so don't go looking for it. ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) ord_idecls - -- GHC.Prim doesn't exist physically, so don't go looking for it. + + implicit_prelude = xopt Opt_ImplicitPrelude dflags + implicit_imports = mkPrelImports (unLoc mod) implicit_prelude imps in - return (src_idecls, ordinary_imps, mod) - -parseError :: GhcMonad m => SrcSpan -> Message -> m a + return (src_idecls, implicit_imports ++ ordinary_imps, mod) + +mkPrelImports :: ModuleName -> Bool -> [LImportDecl RdrName] + -> [LImportDecl RdrName] +-- Consruct the implicit declaration "import Prelude" (or not) +-- +-- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); +-- because the former doesn't even look at Prelude.hi for instance +-- declarations, whereas the latter does. +mkPrelImports this_mod implicit_prelude import_decls + | this_mod == pRELUDE_NAME + || explicit_prelude_import + || not implicit_prelude + = [] + | otherwise = [preludeImportDecl] + where + explicit_prelude_import + = notNull [ () | L _ (ImportDecl mod Nothing _ _ _ _) <- import_decls, + unLoc mod == pRELUDE_NAME ] + + preludeImportDecl :: LImportDecl RdrName + preludeImportDecl + = L loc $ + ImportDecl (L loc pRELUDE_NAME) + Nothing {- no specific package -} + False {- Not a boot interface -} + False {- Not qualified -} + Nothing {- No "as" -} + Nothing {- No import list -} + + loc = mkGeneralSrcSpan (fsLit "Implicit import declaration") + +parseError :: SrcSpan -> Message -> IO a parseError span err = throwOneError $ mkPlainErrMsg span err -------------------------------------------------------------- @@ -106,7 +143,7 @@ lazyGetToks dflags filename handle = do buf <- hGetStringBufferBlock handle blockSize unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False where - loc = mkSrcLoc (mkFastString filename) 1 0 + loc = mkRealSrcLoc (mkFastString filename) 1 1 lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token] lazyLexBuf handle state eof = do @@ -123,8 +160,9 @@ lazyGetToks dflags filename handle = do _other -> do rest <- lazyLexBuf handle state' eof return (t : rest) _ | not eof -> getMore handle state - | otherwise -> return [] - + | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof] + -- parser assumes an ITeof sentinel at the end + getMore :: Handle -> PState -> IO [Located Token] getMore handle state = do -- pprTrace "getMore" (text (show (buffer state))) (return ()) @@ -137,12 +175,12 @@ lazyGetToks dflags filename handle = do getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token] getToks dflags filename buf = lexAll (pragState dflags buf loc) where - loc = mkSrcLoc (mkFastString filename) 1 0 + loc = mkRealSrcLoc (mkFastString filename) 1 1 lexAll state = case unP (lexer return) state of POk _ t@(L _ ITeof) -> [t] POk state' t -> t : lexAll state' - _ -> [L (last_loc state) ITeof] + _ -> [L (RealSrcSpan (last_loc state)) ITeof] -- | Parse OPTIONS and LANGUAGE pragmas of the source file. @@ -189,6 +227,9 @@ getOptions' toks parseToks (open:xs) | ITlanguage_prag <- getToken open = parseLanguage xs + parseToks (x:xs) + | ITdocCommentNext _ <- getToken x + = parseToks xs parseToks _ = [] parseLanguage (L loc (ITconid fs):rest) = checkExtension (L loc fs) : @@ -214,7 +255,7 @@ checkProcessArgsResult flags liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags where mkMsg (L loc flag) = mkPlainErrMsg loc $ - (text "unknown flag in {-# OPTIONS #-} pragma:" <+> + (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag) ----------------------------------------------------------------------------- @@ -224,8 +265,7 @@ checkExtension (L l ext) -- Checks if a given extension is valid, and if so returns -- its corresponding flag. Otherwise it throws an exception. = let ext' = unpackFS ext in - if ext' `elem` supportedLanguages - || ext' `elem` (map ("No"++) supportedLanguages) + if ext' `elem` supportedLanguagesAndExtensions then L l ("-X"++ext') else unsupportedExtnError l ext' @@ -233,13 +273,19 @@ languagePragParseError :: SrcSpan -> a languagePragParseError loc = throw $ mkSrcErr $ unitBag $ (mkPlainErrMsg loc $ - text "cannot parse LANGUAGE pragma: comma-separated list expected") + vcat [ text "Cannot parse LANGUAGE pragma" + , text "Expecting comma-separated list of language options," + , text "each starting with a capital letter" + , nest 2 (text "E.g. {-# LANGUAGE RecordPuns, Generics #-}") ]) unsupportedExtnError :: SrcSpan -> String -> a unsupportedExtnError loc unsup = throw $ mkSrcErr $ unitBag $ mkPlainErrMsg loc $ - text "unsupported extension: " <> text unsup + text "Unsupported extension: " <> text unsup $$ + if null suggestions then empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions) + where + suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages @@ -249,5 +295,5 @@ optionsErrorMsgs unhandled_flags flags_lines _filename L l f' <- flags_lines, f == f' ] mkMsg (L flagSpan flag) = ErrUtils.mkPlainErrMsg flagSpan $ - text "unknown flag in {-# OPTIONS #-} pragma:" <+> text flag + text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag