Parameterise Messages over e

This commit paves the way to a richer and more structured representation
of GHC error messages, as per GHC proposal #306. More specifically
'Messages' from 'GHC.Types.Error' now gains an extra type parameter,
that we instantiate to 'ErrDoc' for now. Later, this will allow us to
replace ErrDoc with something more structure (for example messages
coming from the parser, the typechecker etc).

1 files changed, 15 insertions, 18 deletions

diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index 7e52691124..a4b4652277 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -83,7 +83,6 @@ import GHC.Tc.Utils.TcMType ( checkForLevPolyX, formatLevPolyErr )
 
 import GHC.Builtin.Names
 
-import GHC.Data.Bag
 import GHC.Data.FastString
 
 import GHC.Unit.Env
@@ -104,9 +103,9 @@ import GHC.Types.Name.Ppr
 import GHC.Types.Literal ( mkLitString )
 import GHC.Types.CostCentre.State
 import GHC.Types.TyThing
+import GHC.Types.Error
 
 import GHC.Utils.Outputable
-import GHC.Utils.Error
 import GHC.Utils.Panic
 
 import Data.IORef
@@ -214,7 +213,7 @@ initDsTc thing_inside
        }
 
 -- | Run a 'DsM' action inside the 'IO' monad.
-initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)
+initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages ErrDoc, Maybe a)
 initDs hsc_env tcg_env thing_inside
   = do { msg_var <- newIORef emptyMessages
        ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
@@ -223,7 +222,7 @@ initDs hsc_env tcg_env thing_inside
 
 -- | Build a set of desugarer environments derived from a 'TcGblEnv'.
 mkDsEnvsFromTcGbl :: MonadIO m
-                  => HscEnv -> IORef Messages -> TcGblEnv
+                  => HscEnv -> IORef (Messages ErrDoc) -> TcGblEnv
                   -> m (DsGblEnv, DsLclEnv)
 mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
   = do { cc_st_var   <- liftIO $ newIORef newCostCentreState
@@ -240,21 +239,20 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
                            msg_var cc_st_var complete_matches
        }
 
-runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
+runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages ErrDoc, Maybe a)
 runDs hsc_env (ds_gbl, ds_lcl) thing_inside
   = do { res    <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl
                               (tryM thing_inside)
        ; msgs   <- readIORef (ds_msgs ds_gbl)
        ; let final_res
-               | errorsFound dflags msgs = Nothing
-               | Right r <- res          = Just r
-               | otherwise               = panic "initDs"
+               | errorsFound msgs = Nothing
+               | Right r <- res   = Just r
+               | otherwise        = panic "initDs"
        ; return (msgs, final_res)
        }
-  where dflags = hsc_dflags hsc_env
 
 -- | Run a 'DsM' action in the context of an existing 'ModGuts'
-initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
+initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages ErrDoc, Maybe a)
 initDsWithModGuts hsc_env guts thing_inside
   = do { cc_st_var   <- newIORef newCostCentreState
        ; msg_var <- newIORef emptyMessages
@@ -278,7 +276,7 @@ initDsWithModGuts hsc_env guts thing_inside
        ; runDs hsc_env envs thing_inside
        }
 
-initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)
+initTcDsForSolver :: TcM a -> DsM (Messages ErrDoc, Maybe a)
 -- Spin up a TcM context so that we can run the constraint solver
 -- Returns any error messages generated by the constraint solver
 -- and (Just res) if no error happened; Nothing if an error happened
@@ -309,7 +307,7 @@ initTcDsForSolver thing_inside
          thing_inside }
 
 mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-         -> IORef Messages -> IORef CostCentreState -> CompleteMatches
+         -> IORef (Messages ErrDoc) -> IORef CostCentreState -> CompleteMatches
          -> (DsGblEnv, DsLclEnv)
 mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var
          complete_matches
@@ -455,7 +453,7 @@ warnDs reason warn
        ; loc <- getSrcSpanDs
        ; let msg = makeIntoWarning reason $
                    mkWarnMsg loc (ds_unqual env) warn
-       ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
+       ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }
 
 -- | Emit a warning only if the correct WarnReason is set in the DynFlags
 warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
@@ -468,7 +466,7 @@ errDs err
   = do  { env <- getGblEnv
         ; loc <- getSrcSpanDs
         ; let msg = mkErrMsg loc (ds_unqual env) err
-        ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) }
+        ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }
 
 -- | Issue an error, but return the expression for (), so that we can continue
 -- reporting errors.
@@ -506,14 +504,13 @@ askNoErrsDs thing_inside
                   thing_inside
 
       -- Propagate errors
-      ; msgs@(warns, errs) <- readMutVar errs_var
-      ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs))
+      ; msgs <- readMutVar errs_var
+      ; updMutVar (ds_msgs env) (unionMessages msgs)
 
       -- And return
       ; case mb_res of
            Left _    -> failM
-           Right res -> do { dflags <- getDynFlags
-                           ; let errs_found = errorsFound dflags msgs
+           Right res -> do { let errs_found = errorsFound msgs
                            ; return (res, not errs_found) } }
 
 mkPrintUnqualifiedDs :: DsM PrintUnqualified