Introduce the DecoratedSDoc type

This commit introduces a DecoratedSDoc type which replaces the old
ErrDoc, and hopefully better reflects the intent.

1 files changed, 24 insertions, 16 deletions

diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index ead974bdcf..c92da610fb 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -75,7 +75,7 @@ module GHC.Tc.Utils.Monad(
   tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage,
 
   -- * Shared error message stuff: renamer and typechecker
-  mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,
+  mkLongErrAt, mkDecoratedSDocAt, addLongErrAt, reportErrors, reportError,
   reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,
   attemptM, tryTc,
   askNoErrs, discardErrs, tryTcDiscardingErrs,
@@ -231,7 +231,7 @@ initTc :: HscEnv
        -> Module
        -> RealSrcSpan
        -> TcM r
-       -> IO (Messages [SDoc], Maybe r)
+       -> IO (Messages DecoratedSDoc, Maybe r)
                 -- Nothing => error thrown by the thing inside
                 -- (error messages should have been printed already)
 
@@ -353,7 +353,7 @@ initTcWithGbl :: HscEnv
               -> TcGblEnv
               -> RealSrcSpan
               -> TcM r
-              -> IO (Messages [SDoc], Maybe r)
+              -> IO (Messages DecoratedSDoc, Maybe r)
 initTcWithGbl hsc_env gbl_env loc do_this
  = do { lie_var      <- newIORef emptyWC
       ; errs_var     <- newIORef emptyMessages
@@ -399,7 +399,7 @@ initTcWithGbl hsc_env gbl_env loc do_this
       ; return (msgs, final_res)
       }
 
-initTcInteractive :: HscEnv -> TcM a -> IO (Messages [SDoc], Maybe a)
+initTcInteractive :: HscEnv -> TcM a -> IO (Messages DecoratedSDoc, Maybe a)
 -- Initialise the type checker monad for use in GHCi
 initTcInteractive hsc_env thing_inside
   = initTc hsc_env HsSrcFile False
@@ -930,10 +930,10 @@ wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a)
 
 -- Reporting errors
 
-getErrsVar :: TcRn (TcRef (Messages [SDoc]))
+getErrsVar :: TcRn (TcRef (Messages DecoratedSDoc))
 getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
 
-setErrsVar :: TcRef (Messages [SDoc]) -> TcRn a -> TcRn a
+setErrsVar :: TcRef (Messages DecoratedSDoc) -> TcRn a -> TcRn a
 setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })
 
 addErr :: SDoc -> TcRn ()
@@ -963,7 +963,7 @@ checkErr :: Bool -> SDoc -> TcRn ()
 -- Add the error if the bool is False
 checkErr ok msg = unless ok (addErr msg)
 
-addMessages :: Messages [SDoc] -> TcRn ()
+addMessages :: Messages DecoratedSDoc -> TcRn ()
 addMessages msgs1
   = do { errs_var <- getErrsVar ;
          msgs0 <- readTcRef errs_var ;
@@ -992,36 +992,44 @@ discardWarnings thing_inside
 ************************************************************************
 -}
 
-mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope [SDoc])
+mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope DecoratedSDoc)
 mkLongErrAt loc msg extra
   = do { printer <- getPrintUnqualified ;
          unit_state <- hsc_units <$> getTopEnv ;
          let msg' = pprWithUnitState unit_state msg in
          return $ mkLongMsgEnvelope loc printer msg' extra }
 
-mkErrDocAt :: SrcSpan -> [SDoc] -> TcRn (MsgEnvelope [SDoc])
-mkErrDocAt loc errDoc
+mkDecoratedSDocAt :: SrcSpan
+                  -> SDoc
+                  -- ^ The important part of the message
+                  -> SDoc
+                  -- ^ The context of the message
+                  -> SDoc
+                  -- ^ Any supplementary information.
+                  -> TcRn (MsgEnvelope DecoratedSDoc)
+mkDecoratedSDocAt loc important context extra
   = do { printer <- getPrintUnqualified ;
          unit_state <- hsc_units <$> getTopEnv ;
          let f = pprWithUnitState unit_state
-             errDoc' = map f errDoc
+             errDoc  = [important, context, extra]
+             errDoc' = mkDecorated $ map f errDoc
          in
          return $ mkErr loc printer errDoc' }
 
 addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn ()
 addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError
 
-reportErrors :: [MsgEnvelope [SDoc]] -> TcM ()
+reportErrors :: [MsgEnvelope DecoratedSDoc] -> TcM ()
 reportErrors = mapM_ reportError
 
-reportError :: MsgEnvelope [SDoc] -> TcRn ()
+reportError :: MsgEnvelope DecoratedSDoc -> TcRn ()
 reportError err
   = do { traceTc "Adding error:" (pprLocMsgEnvelope err) ;
          errs_var <- getErrsVar ;
          msgs     <- readTcRef errs_var ;
          writeTcRef errs_var (err `addMessage` msgs) }
 
-reportWarning :: WarnReason -> MsgEnvelope [SDoc] -> TcRn ()
+reportWarning :: WarnReason -> MsgEnvelope DecoratedSDoc -> TcRn ()
 reportWarning reason err
   = do { let warn = makeIntoWarning reason err
                     -- 'err' was built by mkLongMsgEnvelope or something like that,
@@ -1191,7 +1199,7 @@ capture_constraints thing_inside
        ; lie <- readTcRef lie_var
        ; return (res, lie) }
 
-capture_messages :: TcM r -> TcM (r, Messages [SDoc])
+capture_messages :: TcM r -> TcM (r, Messages DecoratedSDoc)
 -- capture_messages simply captures and returns the
 --                  errors arnd warnings generated by thing_inside
 -- Precondition: thing_inside must not throw an exception!
@@ -1361,7 +1369,7 @@ foldAndRecoverM f acc (x:xs) =
                                 Just acc' -> foldAndRecoverM f acc' xs  }
 
 -----------------------
-tryTc :: TcRn a -> TcRn (Maybe a, Messages [SDoc])
+tryTc :: TcRn a -> TcRn (Maybe a, Messages DecoratedSDoc)
 -- (tryTc m) executes m, and returns
 --      Just r,  if m succeeds (returning r)
 --      Nothing, if m fails