Refactoring and tidyup of HscMain and related things (also fix #1666)

While trying to fix #1666 (-Werror aborts too early) I decided to some
tidyup in GHC/DriverPipeline/HscMain.

 - The GhcMonad overloading is gone from DriverPipeline and HscMain
   now.  GhcMonad is now defined in a module of its own, and only
   used in the top-level GHC layer.  DriverPipeline and HscMain
   use the plain IO monad and take HscEnv as an argument.

 - WarnLogMonad is gone.  printExceptionAndWarnings is now called
   printException (the old name is deprecated).  Session no longer
   contains warnings.

 - HscMain has its own little monad that collects warnings, and also
   plumbs HscEnv around.  The idea here is that warnings are collected
   while we're in HscMain, but on exit from HscMain (any function) we
   check for warnings and either print them (via log_action, so IDEs
   can still override the printing), or turn them into an error if
   -Werror is on.

 - GhcApiCallbacks is gone, along with GHC.loadWithLogger.  Thomas
   Schilling told me he wasn't using these, and I don't see a good
   reason to have them.

 - there's a new pure API to the parser (suggestion from Neil Mitchell):
      parser :: String
             -> DynFlags
             -> FilePath
             -> Either ErrorMessages (WarningMessages, 
                                      Located (HsModule RdrName))

1 files changed, 12 insertions, 40 deletions

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index 3ab89bd733..15b142b15d 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -13,7 +13,7 @@ module ErrUtils (
         errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
 	Messages, errorsFound, emptyMessages,
 	mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
-	printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
+	printBagOfErrors, printBagOfWarnings,
 	warnIsErrorMsg, mkLongWarnMsg,
 
 	ghcExit,
@@ -39,7 +39,6 @@ import SrcLoc
 import DynFlags		( DynFlags(..), DynFlag(..), dopt )
 import StaticFlags	( opt_ErrorSpans )
 
-import Control.Monad
 import System.Exit	( ExitCode(..), exitWith )
 import Data.List
 import System.IO
@@ -126,56 +125,29 @@ emptyMessages :: Messages
 emptyMessages = (emptyBag, emptyBag)
 
 warnIsErrorMsg :: ErrMsg
-warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.\n")
+warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.")
 
 errorsFound :: DynFlags -> Messages -> Bool
--- The dyn-flags are used to see if the user has specified
--- -Werror, which says that warnings should be fatal
-errorsFound dflags (warns, errs) 
-  | dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns)
-  | otherwise  		        = not (isEmptyBag errs)
-
-printErrorsAndWarnings :: DynFlags -> Messages -> IO ()
-printErrorsAndWarnings dflags (warns, errs)
-  | no_errs && no_warns = return ()
-  | no_errs             = do printBagOfWarnings dflags warns
-                             when (dopt Opt_WarnIsError dflags) $
-                                 errorMsg dflags $
-                                     text "\nFailing due to -Werror.\n"
-                          -- Don't print any warnings if there are errors
-  | otherwise           = printBagOfErrors dflags errs
-  where
-    no_warns = isEmptyBag warns
-    no_errs  = isEmptyBag errs
+errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
 
 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
-printBagOfErrors dflags bag_of_errors
-  = sequence_   [ let style = mkErrStyle unqual
-		  in log_action dflags SevError s style (d $$ e)
-		| ErrMsg { errMsgSpans = s:_,
-			   errMsgShortDoc = d,
-			   errMsgExtraInfo = e,
-			   errMsgContext = unqual } <- sorted_errs ]
-    where
-      bag_ls	  = bagToList bag_of_errors
-      sorted_errs = sortLe occ'ed_before bag_ls
+printBagOfErrors dflags bag_of_errors = 
+  printMsgBag dflags bag_of_errors SevError
 
-      occ'ed_before err1 err2 = 
-         case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
-		LT -> True
-		EQ -> True
-		GT -> False
+printBagOfWarnings :: DynFlags -> Bag WarnMsg -> IO ()
+printBagOfWarnings dflags bag_of_warns = 
+  printMsgBag dflags bag_of_warns SevWarning
 
-printBagOfWarnings :: DynFlags -> Bag ErrMsg -> IO ()
-printBagOfWarnings dflags bag_of_warns
+printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO ()
+printMsgBag dflags bag sev
   = sequence_   [ let style = mkErrStyle unqual
-		  in log_action dflags SevWarning s style (d $$ e)
+		  in log_action dflags sev s style (d $$ e)
 		| ErrMsg { errMsgSpans = s:_,
 			   errMsgShortDoc = d,
 			   errMsgExtraInfo = e,
 			   errMsgContext = unqual } <- sorted_errs ]
     where
-      bag_ls	  = bagToList bag_of_warns
+      bag_ls	  = bagToList bag
       sorted_errs = sortLe occ'ed_before bag_ls
 
       occ'ed_before err1 err2 =