X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FHeaderInfo.hs;h=a88563c35506e37cd0ed5ec370f4454921afa440;hb=eb0e20bd2c73df8c6e2eb05f6545ced2e9b91b75;hp=eea6b52fc21a1357baf6e8d917d46842711b5e87;hpb=1867a7bb8c59ea514b4f47f5434842543933ec9a;p=ghc-hetmet.git

diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index eea6b52..a88563c 100644
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -1,13 +1,6 @@
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 -----------------------------------------------------------------------------
 --
--- Parsing the top of a Haskell source file to get its module name,
+-- | Parsing the top of a Haskell source file to get its module name,
 -- imports and options.
 --
 -- (c) Simon Marlow 2005
@@ -22,6 +15,7 @@ module HeaderInfo ( getImports
 
 #include "HsVersions.h"
 
+import HscTypes
 import Parser		( parseHeader )
 import Lexer
 import FastString
@@ -36,26 +30,39 @@ import ErrUtils
 import Util
 import Outputable
 import Pretty           ()
-import Panic
 import Maybes
-import Bag		( emptyBag, listToBag )
+import Bag		( emptyBag, listToBag, unitBag )
 
+import MonadUtils       ( MonadIO )
 import Exception
 import Control.Monad
-import System.Exit
 import System.IO
 import Data.List
 
-getImports :: DynFlags -> StringBuffer -> FilePath -> FilePath
-    -> IO ([Located ModuleName], [Located ModuleName], Located ModuleName)
+------------------------------------------------------------------------------
+
+-- | Parse the imports of a source file.
+--
+-- Throws a 'SourceError' if parsing fails.
+getImports :: GhcMonad m =>
+              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 ModuleName], [Located ModuleName], 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
-	PFailed span err -> parseError span err
-	POk pst rdr_module -> do
-          let ms = getMessages pst
-          printErrorsAndWarnings dflags ms
-          when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
+    PFailed span err -> parseError span err
+    POk pst rdr_module -> do
+      let ms@(warns, errs) = getMessages pst
+      logWarnings warns
+      if errorsFound dflags ms
+        then liftIO $ throwIO $ mkSrcErr errs
+        else
 	  case rdr_module of
 	    L _ (HsModule mb_mod _ imps _ _ _ _) ->
 	      let
@@ -70,8 +77,8 @@ getImports dflags buf filename source_filename = do
 	      in
 	      return (source_imps, ordinary_imps, mod)
   
-parseError :: SrcSpan -> Message -> a
-parseError span err = throwErrMsg $ mkPlainErrMsg span err
+parseError :: GhcMonad m => SrcSpan -> Message -> m a
+parseError span err = throwOneError $ mkPlainErrMsg span err
 
 -- we aren't interested in package imports here, filter them out
 isHomeImp :: ImportDecl name -> Bool
@@ -174,8 +181,11 @@ getOptions' dflags buf filename
                   (_,L _loc ITcomma):more -> parseLanguage more
                   (_,L _loc ITclose_prag):more -> parseToks more
                   (_,L loc _):_ -> languagePragParseError loc
+                  [] -> panic "getOptions'.parseLanguage(1) went past eof token"
           parseLanguage (tok:_)
               = languagePragParseError (getLoc tok)
+          parseLanguage []
+              = panic "getOptions'.parseLanguage(2) went past eof token"
           lexToken t = return t
           lexAll state = case unP (lexer lexToken) state of
                            POk _      t@(L _ ITeof) -> [(buffer state,t)]
@@ -185,13 +195,14 @@ getOptions' dflags buf filename
 -----------------------------------------------------------------------------
 -- Complain about non-dynamic flags in OPTIONS pragmas
 
-checkProcessArgsResult :: [String] -> FilePath -> IO ()
-checkProcessArgsResult flags filename
-  = do when (notNull flags) (ghcError (ProgramError (
-          showSDoc (hang (text filename <> char ':')
-                      4 (text "unknown flags in  {-# OPTIONS #-} pragma:" <+>
-                          hsep (map text flags)))
-        )))
+checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
+checkProcessArgsResult flags
+  = when (notNull flags) $
+      liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
+    where mkMsg (L loc flag)
+              = mkPlainErrMsg loc $
+                  (text "unknown flag in  {-# OPTIONS #-} pragma:" <+>
+                   text flag)
 
 -----------------------------------------------------------------------------
 
@@ -207,15 +218,15 @@ checkExtension (L l ext)
 
 languagePragParseError :: SrcSpan -> a
 languagePragParseError loc =
-  pgmError 
-   (showSDoc (mkLocMessage loc (
-     text "cannot parse LANGUAGE pragma: comma-separated list expected")))
+  throw $ mkSrcErr $ unitBag $
+     (mkPlainErrMsg loc $
+       text "cannot parse LANGUAGE pragma: comma-separated list expected")
 
 unsupportedExtnError :: SrcSpan -> String -> a
 unsupportedExtnError loc unsup =
-  pgmError (showSDoc (mkLocMessage loc (
-                text "unsupported extension: " <>
-                text unsup)))
+  throw $ mkSrcErr $ unitBag $
+    mkPlainErrMsg loc $
+        text "unsupported extension: " <> text unsup
 
 
 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages