projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Bottom extraction: float out bottoming expressions to top level
[ghc-hetmet.git]
/
compiler
/
main
/
HeaderInfo.hs
diff --git
a/compiler/main/HeaderInfo.hs
b/compiler/main/HeaderInfo.hs
index
89f4661
..
597253e
100644
(file)
--- a/
compiler/main/HeaderInfo.hs
+++ b/
compiler/main/HeaderInfo.hs
@@
-55,19
+55,22
@@
getImports :: GhcMonad m =>
-> m ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
-- ^ The source imports, normal imports, and the module name.
getImports dflags buf filename source_filename = do
-> m ([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
+ let loc = mkSrcLoc (mkFastString filename) 1 1
case unP parseHeader (mkPState buf loc dflags) of
PFailed span err -> parseError span err
POk pst rdr_module -> do
case unP parseHeader (mkPState buf loc dflags) 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
else
case rdr_module of
if errorsFound dflags ms
then liftIO $ throwIO $ mkSrcErr errs
else
case rdr_module of
- L _ (HsModule mb_mod _ imps _ _ _ _) ->
+ L _ (HsModule mb_mod _ imps _ _ _) ->
let
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
ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
(src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
@@
-106,7
+109,7
@@
lazyGetToks dflags filename handle = do
buf <- hGetStringBufferBlock handle blockSize
unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False
where
buf <- hGetStringBufferBlock handle blockSize
unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False
where
- loc = mkSrcLoc (mkFastString filename) 1 0
+ loc = mkSrcLoc (mkFastString filename) 1 1
lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token]
lazyLexBuf handle state eof = do
lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token]
lazyLexBuf handle state eof = do
@@
-123,8
+126,9
@@
lazyGetToks dflags filename handle = do
_other -> do rest <- lazyLexBuf handle state' eof
return (t : rest)
_ | not eof -> getMore handle state
_other -> do rest <- lazyLexBuf handle state' eof
return (t : rest)
_ | not eof -> getMore handle state
- | otherwise -> return []
-
+ | otherwise -> return [L (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 ())
getMore :: Handle -> PState -> IO [Located Token]
getMore handle state = do
-- pprTrace "getMore" (text (show (buffer state))) (return ())
@@
-137,7
+141,7
@@
lazyGetToks dflags filename handle = do
getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
getToks dflags filename buf = lexAll (pragState dflags buf loc)
where
getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
getToks dflags filename buf = lexAll (pragState dflags buf loc)
where
- loc = mkSrcLoc (mkFastString filename) 1 0
+ loc = mkSrcLoc (mkFastString filename) 1 1
lexAll state = case unP (lexer return) state of
POk _ t@(L _ ITeof) -> [t]
lexAll state = case unP (lexer return) state of
POk _ t@(L _ ITeof) -> [t]
@@
-233,13
+237,16
@@
languagePragParseError :: SrcSpan -> a
languagePragParseError loc =
throw $ mkSrcErr $ unitBag $
(mkPlainErrMsg loc $
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 $
unsupportedExtnError :: SrcSpan -> String -> a
unsupportedExtnError loc unsup =
throw $ mkSrcErr $ unitBag $
mkPlainErrMsg loc $
- text "unsupported extension: " <> text unsup
+ text "Unsupported extension: " <> text unsup
optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages