Allow proper errors/warnings in core2core passes

This patch makes it possible for core-to-core passes to emit
proper error messages and warnings.

  * New function CoreMonad.warnMsg

  * CoreMonad.warnMsg and errorMsg now print a proper warning/error
    message heading.

  * CoreMonad carries a SrcSpan, which is used in warning/error
    messages.  It is initialised to be the source file name, but
    a core-to-core pass could set it more specifically if it had
    better location information.

There was a bit of plumbing needed to get the filename to the
right place.

9 files changed, 90 insertions, 35 deletions

diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs
index 362a925992..65d7e71ac9 100644
--- a/compiler/basicTypes/SrcLoc.hs
+++ b/compiler/basicTypes/SrcLoc.hs
@@ -41,6 +41,7 @@ module SrcLoc (
         mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,
         noSrcSpan,
         wiredInSrcSpan,         -- Something wired into the compiler
+        interactiveSrcSpan,
         srcLocSpan, realSrcLocSpan,
         combineSrcSpans,
 
@@ -131,7 +132,7 @@ mkRealSrcLoc x line col = SrcLoc x line col
 noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc
 noSrcLoc          = UnhelpfulLoc (fsLit "<no location info>")
 generatedSrcLoc   = UnhelpfulLoc (fsLit "<compiler-generated code>")
-interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive session>")
+interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive>")
 
 -- | Creates a "bad" 'SrcLoc' that has no detailed information about its location
 mkGeneralSrcLoc :: FastString -> SrcLoc
@@ -278,9 +279,10 @@ data SrcSpan =
                                      -- derive Show for Token
 
 -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty
-noSrcSpan, wiredInSrcSpan :: SrcSpan
-noSrcSpan      = UnhelpfulSpan (fsLit "<no location info>")
-wiredInSrcSpan = UnhelpfulSpan (fsLit "<wired into compiler>")
+noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan
+noSrcSpan          = UnhelpfulSpan (fsLit "<no location info>")
+wiredInSrcSpan     = UnhelpfulSpan (fsLit "<wired into compiler>")
+interactiveSrcSpan = UnhelpfulSpan (fsLit "<interactive>")
 
 -- | Create a "bad" 'SrcSpan' that has not location information
 mkGeneralSrcSpan :: FastString -> SrcSpan
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 5bf2d4f1d2..2b1118e69b 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -1905,7 +1905,8 @@ withoutAnnots pass guts = do
         liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*>
                                 getUniqueSupplyM <*> getModule <*>
                                 getVisibleOrphanMods <*>
-                                getPrintUnqualified <*> pure corem
+                                getPrintUnqualified <*> getSrcSpanM <*>
+                                pure corem
   -- Nuke existing ticks in module.
   -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes
   -- them in absence of @Opt_Debug@?
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index 09e2554b05..94ee7faab3 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -171,6 +171,7 @@ deSugar hsc_env
         ; let mod_guts = ModGuts {
                 mg_module       = mod,
                 mg_hsc_src      = hsc_src,
+                mg_loc          = mkFileSrcSpan mod_loc,
                 mg_exports      = exports,
                 mg_deps         = deps,
                 mg_used_names   = used_names,
@@ -200,6 +201,12 @@ deSugar hsc_env
         ; return (msgs, Just mod_guts)
         }}}
 
+mkFileSrcSpan :: ModLocation -> SrcSpan
+mkFileSrcSpan mod_loc
+  = case ml_hs_file mod_loc of
+      Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
+      Nothing        -> interactiveSrcSpan   -- Presumably
+
 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
 dsImpSpecs imp_specs
  = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index 1155b4b874..3a7d9ece23 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -104,12 +104,25 @@ type WarnMsg = ErrMsg
 
 data Severity
   = SevOutput
-  | SevDump
+  | SevFatal
   | SevInteractive
+
+  | SevDump
+    -- Log messagse intended for compiler developers
+    -- No file/line/column stuff
+
   | SevInfo
+    -- Log messages intended for end users.
+    -- No file/line/column stuff.
+
   | SevWarning
   | SevError
-  | SevFatal
+    -- SevWarning and SevError are used for warnings and errors
+    --   o The message has a file/line/column heading,
+    --     plus "warning:" or "error:",
+    --     added by mkLocMessags
+    --   o Output is intended for end users
+
 
 instance Show ErrMsg where
     show em = errMsgShortString em
diff --git a/compiler/main/ErrUtils.hs-boot b/compiler/main/ErrUtils.hs-boot
index ac1673b367..31edcc05ee 100644
--- a/compiler/main/ErrUtils.hs-boot
+++ b/compiler/main/ErrUtils.hs-boot
@@ -5,12 +5,13 @@ import SrcLoc (SrcSpan)
 
 data Severity
   = SevOutput
-  | SevDump
+  | SevFatal
   | SevInteractive
+  | SevDump
   | SevInfo
   | SevWarning
   | SevError
-  | SevFatal
+
 
 type MsgDoc = SDoc
 
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 328655c6d0..c7cabe6f9a 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -1643,6 +1643,8 @@ mkModGuts mod safe binds =
     ModGuts {
         mg_module       = mod,
         mg_hsc_src      = HsSrcFile,
+        mg_loc          = mkGeneralSrcSpan (moduleNameFS (moduleName mod)),
+                                  -- A bit crude
         mg_exports      = [],
         mg_deps         = noDependencies,
         mg_dir_imps     = emptyModuleEnv,
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 7bceda50f6..b3ae6714db 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -1054,6 +1054,7 @@ data ModGuts
   = ModGuts {
         mg_module    :: !Module,         -- ^ Module being compiled
         mg_hsc_src   :: HscSource,       -- ^ Whether it's an hs-boot module
+        mg_loc       :: SrcSpan,         -- ^ For error messages from inner passes
         mg_exports   :: ![AvailInfo],    -- ^ What it exports
         mg_deps      :: !Dependencies,   -- ^ What it depends on, directly or
                                          -- otherwise
diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs
index fc69fdc681..68b613bc19 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -28,7 +28,7 @@ module CoreMonad (
     getHscEnv, getRuleBase, getModule,
     getDynFlags, getOrigNameCache, getPackageFamInstEnv,
     getVisibleOrphanMods,
-    getPrintUnqualified,
+    getPrintUnqualified, getSrcSpanM,
 
     -- ** Writing to the monad
     addSimplCount,
@@ -44,7 +44,7 @@ module CoreMonad (
     getAnnotations, getFirstAnnotations,
 
     -- ** Screen output
-    putMsg, putMsgS, errorMsg, errorMsgS,
+    putMsg, putMsgS, errorMsg, errorMsgS, warnMsg,
     fatalErrorMsg, fatalErrorMsgS,
     debugTraceMsg, debugTraceMsgS,
     dumpIfSet_dyn,
@@ -74,11 +74,12 @@ import Var
 import Outputable
 import FastString
 import qualified ErrUtils as Err
+import ErrUtils( Severity(..) )
 import Maybes
 import UniqSupply
 import UniqFM       ( UniqFM, mapUFM, filterUFM )
 import MonadUtils
-
+import SrcLoc
 import ListSetOps       ( runs )
 import Data.List
 import Data.Ord
@@ -516,11 +517,13 @@ newtype CoreState = CoreState {
 }
 
 data CoreReader = CoreReader {
-        cr_hsc_env :: HscEnv,
-        cr_rule_base :: RuleBase,
-        cr_module :: Module,
+        cr_hsc_env             :: HscEnv,
+        cr_rule_base           :: RuleBase,
+        cr_module              :: Module,
+        cr_print_unqual        :: PrintUnqualified,
+        cr_loc                 :: SrcSpan,   -- Use this for log/error messages so they
+                                             -- are at least tagged with the right source file
         cr_visible_orphan_mods :: !ModuleSet,
-        cr_print_unqual :: PrintUnqualified,
 #ifdef GHCI
         cr_globals :: (MVar PersistentLinkerState, Bool)
 #else
@@ -599,11 +602,12 @@ runCoreM :: HscEnv
          -> Module
          -> ModuleSet
          -> PrintUnqualified
+         -> SrcSpan
          -> CoreM a
          -> IO (a, SimplCount)
-runCoreM hsc_env rule_base us mod orph_imps print_unqual m = do
-        glbls <- saveLinkerGlobals
-        liftM extract $ runIOEnv (reader glbls) $ unCoreM m state
+runCoreM hsc_env rule_base us mod orph_imps print_unqual loc m
+  = do { glbls <- saveLinkerGlobals
+       ; liftM extract $ runIOEnv (reader glbls) $ unCoreM m state }
   where
     reader glbls = CoreReader {
             cr_hsc_env = hsc_env,
@@ -611,7 +615,8 @@ runCoreM hsc_env rule_base us mod orph_imps print_unqual m = do
             cr_module = mod,
             cr_visible_orphan_mods = orph_imps,
             cr_globals = glbls,
-            cr_print_unqual = print_unqual
+            cr_print_unqual = print_unqual,
+            cr_loc = loc
         }
     state = CoreState {
             cs_uniq_supply = us
@@ -678,6 +683,9 @@ getVisibleOrphanMods = read cr_visible_orphan_mods
 getPrintUnqualified :: CoreM PrintUnqualified
 getPrintUnqualified = read cr_print_unqual
 
+getSrcSpanM :: CoreM SrcSpan
+getSrcSpanM = read cr_loc
+
 addSimplCount :: SimplCount -> CoreM ()
 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
 
@@ -810,10 +818,21 @@ we aren't using annotations heavily.
 ************************************************************************
 -}
 
-msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
-msg how doc = do
-        dflags <- getDynFlags
-        liftIO $ how dflags doc
+msg :: Severity -> SDoc -> CoreM ()
+msg sev doc
+  = do { dflags <- getDynFlags
+       ; loc    <- getSrcSpanM
+       ; unqual <- getPrintUnqualified
+       ; let sty = case sev of
+                     SevError   -> err_sty
+                     SevWarning -> err_sty
+                     SevDump    -> dump_sty
+                     _          -> user_sty
+             err_sty  = mkErrStyle dflags unqual
+             user_sty = mkUserStyle unqual AllTheWay
+             dump_sty = mkDumpStyle unqual
+       ; liftIO $
+         (log_action dflags) dflags sev loc sty doc }
 
 -- | Output a String message to the screen
 putMsgS :: String -> CoreM ()
@@ -821,7 +840,7 @@ putMsgS = putMsg . text
 
 -- | Output a message to the screen
 putMsg :: SDoc -> CoreM ()
-putMsg = msg Err.putMsg
+putMsg = msg SevInfo
 
 -- | Output a string error to the screen
 errorMsgS :: String -> CoreM ()
@@ -829,7 +848,10 @@ errorMsgS = errorMsg . text
 
 -- | Output an error to the screen
 errorMsg :: SDoc -> CoreM ()
-errorMsg = msg Err.errorMsg
+errorMsg = msg SevError
+
+warnMsg :: SDoc -> CoreM ()
+warnMsg = msg SevWarning
 
 -- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
 fatalErrorMsgS :: String -> CoreM ()
@@ -837,7 +859,7 @@ fatalErrorMsgS = fatalErrorMsg . text
 
 -- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
 fatalErrorMsg :: SDoc -> CoreM ()
-fatalErrorMsg = msg Err.fatalErrorMsg
+fatalErrorMsg = msg SevFatal
 
 -- | Output a string debugging message at verbosity level of @-v@ or higher
 debugTraceMsgS :: String -> CoreM ()
@@ -845,11 +867,15 @@ debugTraceMsgS = debugTraceMsg . text
 
 -- | Outputs a debugging message at verbosity level of @-v@ or higher
 debugTraceMsg :: SDoc -> CoreM ()
-debugTraceMsg = msg (flip Err.debugTraceMsg 3)
+debugTraceMsg = msg SevDump
 
 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
 dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()
-dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
+dumpIfSet_dyn flag str doc
+  = do { dflags <- getDynFlags
+       ; unqual <- getPrintUnqualified
+       ; when (dopt flag dflags) $ liftIO $
+         Err.dumpSDoc dflags unqual flag str doc }
 
 {-
 ************************************************************************
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index 73cdd704f4..90233d608a 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -68,15 +68,18 @@ import Plugins          ( installCoreToDos )
 -}
 
 core2core :: HscEnv -> ModGuts -> IO ModGuts
-core2core hsc_env guts
+core2core hsc_env guts@(ModGuts { mg_module  = mod
+                                , mg_loc     = loc
+                                , mg_deps    = deps
+                                , mg_rdr_env = rdr_env })
   = do { us <- mkSplitUniqSupply 's'
        -- make sure all plugins are loaded
 
        ; let builtin_passes = getCoreToDo dflags
-             orph_mods = mkModuleSet (mg_module guts : dep_orphs (mg_deps guts))
+             orph_mods = mkModuleSet (mod : dep_orphs deps)
        ;
        ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod
-                                    orph_mods print_unqual $
+                                    orph_mods print_unqual loc $
                            do { all_passes <- addPluginPasses builtin_passes
                               ; runCorePasses all_passes guts }
 
@@ -87,15 +90,14 @@ core2core hsc_env guts
        ; return guts2 }
   where
     dflags         = hsc_dflags hsc_env
-    home_pkg_rules = hptRules hsc_env (dep_mods (mg_deps guts))
+    home_pkg_rules = hptRules hsc_env (dep_mods deps)
     hpt_rule_base  = mkRuleBase home_pkg_rules
-    mod            = mg_module guts
+    print_unqual   = mkPrintUnqualified dflags rdr_env
     -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
     -- This is very convienent for the users of the monad (e.g. plugins do not have to
     -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
     -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
     -- would mean our cached value would go out of date.
-    print_unqual = mkPrintUnqualified dflags (mg_rdr_env guts)
 
 {-
 ************************************************************************