Try to simplify zoo of functions in `Tc.Utils.Monad`

This commit tries to untangle the zoo of diagnostic-related functions
in `Tc.Utils.Monad` so that we can have the interfaces mentions only
`TcRnMessage`s while we push the creation of these messages upstream.

It also ports TcRnMessage diagnostics to use the new API, in particular
this commit switch to use TcRnMessage in the external interfaces
of the diagnostic functions, and port the old SDoc to be wrapped
into TcRnUnknownMessage.

4 files changed, 58 insertions, 36 deletions

diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs
index cd70be7c59..b4c1052385 100644
--- a/compiler/GHC/Tc/TyCl/Class.hs
+++ b/compiler/GHC/Tc/TyCl/Class.hs
@@ -30,6 +30,7 @@ where
 import GHC.Prelude
 
 import GHC.Hs
+import GHC.Tc.Errors.Types
 import GHC.Tc.Gen.Sig
 import GHC.Tc.Types.Evidence ( idHsWrapper )
 import GHC.Tc.Gen.Bind
@@ -50,6 +51,7 @@ import GHC.Core.Coercion ( pprCoAxiom )
 import GHC.Driver.Session
 import GHC.Tc.Instance.Family
 import GHC.Core.FamInstEnv
+import GHC.Types.Error
 import GHC.Types.Id
 import GHC.Types.Name
 import GHC.Types.Name.Env
@@ -112,8 +114,8 @@ Death to "ExpandingDicts".
 ************************************************************************
 -}
 
-illegalHsigDefaultMethod :: Name -> SDoc
-illegalHsigDefaultMethod n =
+illegalHsigDefaultMethod :: Name -> TcRnMessage
+illegalHsigDefaultMethod n = TcRnUnknownMessage $ mkPlainError noHints $
     text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file"
 
 tcClassSigs :: Name                -- Name of the class
@@ -274,10 +276,10 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
 
        ; spec_prags <- discardConstraints $
                        tcSpecPrags global_dm_id prags
-       ; diagnosticTc WarningWithoutFlag
-                      (not (null spec_prags))
-                      (text "Ignoring SPECIALISE pragmas on default method"
-                       <+> quotes (ppr sel_name))
+       ; let dia = TcRnUnknownMessage $
+               mkPlainDiagnostic WarningWithoutFlag noHints $
+                (text "Ignoring SPECIALISE pragmas on default method" <+> quotes (ppr sel_name))
+       ; diagnosticTc (not (null spec_prags)) dia
 
        ; let hs_ty = hs_sig_fn sel_name
                      `orElse` pprPanic "tc_dm" (ppr sel_name)
@@ -353,7 +355,7 @@ tcClassMinimalDef _clas sigs op_info
         -- since you can't write a default implementation.
         when (tcg_src tcg_env /= HsigFile) $
             whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
-                       (\bf -> addDiagnosticTc WarningWithoutFlag (warningMinimalDefIncomplete bf))
+                       (\bf -> addDiagnosticTc (warningMinimalDefIncomplete bf))
         return mindef
   where
     -- By default require all methods without a default implementation
@@ -454,14 +456,16 @@ This makes the error messages right.
 ************************************************************************
 -}
 
-badMethodErr :: Outputable a => a -> Name -> SDoc
+badMethodErr :: Outputable a => a -> Name -> TcRnMessage
 badMethodErr clas op
-  = hsep [text "Class", quotes (ppr clas),
+  = TcRnUnknownMessage $ mkPlainError noHints $
+    hsep [text "Class", quotes (ppr clas),
           text "does not have a method", quotes (ppr op)]
 
-badGenericMethod :: Outputable a => a -> Name -> SDoc
+badGenericMethod :: Outputable a => a -> Name -> TcRnMessage
 badGenericMethod clas op
-  = hsep [text "Class", quotes (ppr clas),
+  = TcRnUnknownMessage $ mkPlainError noHints $
+    hsep [text "Class", quotes (ppr clas),
           text "has a generic-default signature without a binding", quotes (ppr op)]
 
 {-
@@ -485,13 +489,15 @@ dupGenericInsts tc_inst_infos
 -}
 badDmPrag :: TcId -> Sig GhcRn -> TcM ()
 badDmPrag sel_id prag
-  = addErrTc (text "The" <+> hsSigDoc prag <+> text "for default method"
+  = addErrTc (TcRnUnknownMessage $ mkPlainError noHints $
+    text "The" <+> hsSigDoc prag <+> text "for default method"
               <+> quotes (ppr sel_id)
               <+> text "lacks an accompanying binding")
 
-warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc
+warningMinimalDefIncomplete :: ClassMinimalDef -> TcRnMessage
 warningMinimalDefIncomplete mindef
-  = vcat [ text "The MINIMAL pragma does not require:"
+  = TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $
+  vcat [ text "The MINIMAL pragma does not require:"
          , nest 2 (pprBooleanFormulaNice mindef)
          , text "but there is no default implementation." ]
 
@@ -572,7 +578,10 @@ warnMissingAT name
        -- hs-boot and signatures never need to provide complete "definitions"
        -- of any sort, as they aren't really defining anything, but just
        -- constraining items which are defined elsewhere.
-       ; diagnosticTc (WarningWithFlag Opt_WarnMissingMethods) (warn && hsc_src == HsSrcFile)
-                      (text "No explicit" <+> text "associated type"
-                          <+> text "or default declaration for"
-                          <+> quotes (ppr name)) }
+       ; let dia = TcRnUnknownMessage $
+               mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingMethods) noHints $
+                 (text "No explicit" <+> text "associated type"
+                                     <+> text "or default declaration for"
+                                     <+> quotes (ppr name))
+       ; diagnosticTc  (warn && hsc_src == HsSrcFile) dia
+                       }
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index e0bff637a7..760c8c6438 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -22,6 +22,7 @@ where
 import GHC.Prelude
 
 import GHC.Hs
+import GHC.Tc.Errors.Types
 import GHC.Tc.Gen.Bind
 import GHC.Tc.TyCl
 import GHC.Tc.TyCl.Utils ( addTyConsToGblEnv )
@@ -60,6 +61,7 @@ import GHC.Core.Coercion.Axiom
 import GHC.Core.DataCon
 import GHC.Core.ConLike
 import GHC.Core.Class
+import GHC.Types.Error
 import GHC.Types.Var as Var
 import GHC.Types.Var.Env
 import GHC.Types.Var.Set
@@ -68,7 +70,6 @@ import GHC.Types.Basic
 import GHC.Types.Fixity
 import GHC.Driver.Session
 import GHC.Driver.Ppr
-import GHC.Utils.Error
 import GHC.Utils.Logger
 import GHC.Data.FastString
 import GHC.Types.Id
@@ -1995,9 +1996,10 @@ methSigCtxt sel_name sig_ty meth_ty env0
                               , text "   Class sig:" <+> ppr meth_ty ])
        ; return (env2, msg) }
 
-misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc
+misplacedInstSig :: Name -> LHsSigType GhcRn -> TcRnMessage
 misplacedInstSig name hs_ty
-  = vcat [ hang (text "Illegal type signature in instance declaration:")
+  = TcRnUnknownMessage $ mkPlainError noHints $
+    vcat [ hang (text "Illegal type signature in instance declaration:")
               2 (hang (pprPrefixName name)
                     2 (dcolon <+> ppr hs_ty))
          , text "(Use InstanceSigs to allow this)" ]
@@ -2123,7 +2125,9 @@ derivBindCtxt sel_id clas tys
 warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM ()
 warnUnsatisfiedMinimalDefinition mindef
   = do { warn <- woptM Opt_WarnMissingMethods
-       ; diagnosticTc (WarningWithFlag Opt_WarnMissingMethods) warn message
+       ; let msg = TcRnUnknownMessage $
+               mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingMethods) noHints message
+       ; diagnosticTc warn msg
        }
   where
     message = vcat [text "No explicit implementation for"
@@ -2342,26 +2346,30 @@ inst_decl_ctxt :: SDoc -> SDoc
 inst_decl_ctxt doc = hang (text "In the instance declaration for")
                         2 (quotes doc)
 
-badBootFamInstDeclErr :: SDoc
+badBootFamInstDeclErr :: TcRnMessage
 badBootFamInstDeclErr
-  = text "Illegal family instance in hs-boot file"
+  = TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal family instance in hs-boot file"
 
-notFamily :: TyCon -> SDoc
+notFamily :: TyCon -> TcRnMessage
 notFamily tycon
-  = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon)
+  = TcRnUnknownMessage $ mkPlainError noHints $
+    vcat [ text "Illegal family instance for" <+> quotes (ppr tycon)
          , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")]
 
-assocInClassErr :: TyCon -> SDoc
+assocInClassErr :: TyCon -> TcRnMessage
 assocInClassErr name
- = text "Associated type" <+> quotes (ppr name) <+>
+ = TcRnUnknownMessage $ mkPlainError noHints $
+   text "Associated type" <+> quotes (ppr name) <+>
    text "must be inside a class instance"
 
-badFamInstDecl :: TyCon -> SDoc
+badFamInstDecl :: TyCon -> TcRnMessage
 badFamInstDecl tc_name
-  = vcat [ text "Illegal family instance for" <+>
+  = TcRnUnknownMessage $ mkPlainError noHints $
+    vcat [ text "Illegal family instance for" <+>
            quotes (ppr tc_name)
          , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ]
 
-notOpenFamily :: TyCon -> SDoc
+notOpenFamily :: TyCon -> TcRnMessage
 notOpenFamily tc
-  = text "Illegal instance for closed family" <+> quotes (ppr tc)
+  = TcRnUnknownMessage $ mkPlainError noHints $
+  text "Illegal instance for closed family" <+> quotes (ppr tc)
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 5f511d539c..c470258e43 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -25,12 +25,14 @@ import GHC.Tc.Gen.Pat
 import GHC.Core.Multiplicity
 import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType )
 import GHC.Core.TyCo.Subst( extendTvSubstWithClone )
+import GHC.Tc.Errors.Types
 import GHC.Tc.Utils.Monad
 import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv, addInlinePrags )
 import GHC.Tc.Utils.Env
 import GHC.Tc.Utils.TcMType
 import GHC.Tc.Utils.Zonk
 import GHC.Builtin.Types.Prim
+import GHC.Types.Error
 import GHC.Types.Name
 import GHC.Types.Name.Set
 import GHC.Types.SrcLoc
@@ -226,6 +228,7 @@ dependentArgErr :: (Id, DTyCoVarSet) -> TcM ()
 -- See Note [Coercions that escape]
 dependentArgErr (arg, bad_cos)
   = failWithTc $  -- fail here: otherwise we get downstream errors
+    TcRnUnknownMessage $ mkPlainError noHints $
     vcat [ text "Iceland Jack!  Iceland Jack! Stop torturing me!"
          , hang (text "Pattern-bound variable")
               2 (ppr arg <+> dcolon <+> ppr (idType arg))
@@ -370,7 +373,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
        -- The existential 'x' should not appear in the result type
        -- Can't check this until we know P's arity (decl_arity above)
        ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) $ binderVars explicit_ex_bndrs
-       ; checkTc (null bad_tvs) $
+       ; checkTc (null bad_tvs) $ TcRnUnknownMessage $ mkPlainError noHints $
          hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma
                    , text "namely" <+> quotes (ppr pat_ty) ])
             2 (text "mentions existential type variable" <> plural bad_tvs
@@ -645,7 +648,7 @@ addPatSynCtxt (L loc name) thing_inside
 
 wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a
 wrongNumberOfParmsErr name decl_arity missing
-  = failWithTc $
+  = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $
     hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has"
           <+> speakNOf decl_arity (text "argument"))
        2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")
@@ -878,7 +881,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
   = return emptyBag
 
   | Left why <- mb_match_group       -- Can't invert the pattern
-  = setSrcSpan (getLocA lpat) $ failWithTc $
+  = setSrcSpan (getLocA lpat) $ failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $
     vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
                  <+> quotes (ppr ps_name) <> colon)
               2 why
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index 9e13a632ae..dcc57592a5 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -29,6 +29,7 @@ module GHC.Tc.TyCl.Utils(
 
 import GHC.Prelude
 
+import GHC.Tc.Errors.Types
 import GHC.Tc.Utils.Monad
 import GHC.Tc.Utils.Env
 import GHC.Tc.Gen.Bind( tcValBinds )
@@ -64,6 +65,7 @@ import GHC.Data.FastString
 import GHC.Unit.Module
 
 import GHC.Types.Basic
+import GHC.Types.Error
 import GHC.Types.FieldLabel
 import GHC.Types.SrcLoc
 import GHC.Types.SourceFile
@@ -204,7 +206,7 @@ checkTyConIsAcyclic tc m = SynCycleM $ \s ->
 checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM ()
 checkSynCycles this_uid tcs tyclds =
     case runSynCycleM (mapM_ (go emptyTyConSet []) tcs) emptyTyConSet of
-        Left (loc, err) -> setSrcSpan loc $ failWithTc err
+        Left (loc, err) -> setSrcSpan loc $ failWithTc (TcRnUnknownMessage $ mkPlainError noHints err)
         Right _  -> return ()
   where
     -- Try our best to print the LTyClDecl for locally defined things