Error on anon wildcards in tcAnonWildCardOcc

  The code in tcAnonWildCardOcc assumed that it could never encounter
  anonymous wildcards in illegal positions, because the renamer would
  have ruled them out. However, it's possible to sneak past the checks
  in the renamer by using Template Haskell. It isn't possible to simply
  pass on additional information when renaming Template Haskell
  brackets, because we don't know in advance in what context the bracket
  will be spliced in (see test case T15433b). So we accept that we might
  encounter these bogus wildcards in the typechecker and throw the
  appropriate error.

  This patch also migrates the error messages for illegal wildcards in
  types to use the diagnostic infrastructure.

  Fixes #15433

7 files changed, 32 insertions, 115 deletions

diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index 19d27a33cf..adfceeef96 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -42,7 +42,7 @@ import GHC.Rename.Pat
 import GHC.Rename.Names
 import GHC.Rename.Env
 import GHC.Rename.Fixity
-import GHC.Rename.Utils ( HsDocContext(..), mapFvRn
+import GHC.Rename.Utils ( mapFvRn
                         , checkDupRdrNames, checkDupRdrNamesN
                         , warnUnusedLocalBinds
                         , warnForallIdentifier
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index b34581dd8e..6c7a55da1f 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -38,7 +38,7 @@ import GHC.Tc.Utils.Monad
 import GHC.Unit.Module ( getModule, isInteractiveModule )
 import GHC.Rename.Env
 import GHC.Rename.Fixity
-import GHC.Rename.Utils ( HsDocContext(..), bindLocalNamesFV, checkDupNames
+import GHC.Rename.Utils ( bindLocalNamesFV, checkDupNames
                         , bindLocalNames
                         , mapMaybeFvRn, mapFvRn
                         , warnUnusedLocalBinds, typeAppErr
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index 1e1a0b538f..bf31991e8f 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -48,15 +48,15 @@ import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList )
 import GHC.Driver.Session
 import GHC.Hs
 import GHC.Rename.Env
-import GHC.Rename.Utils  ( HsDocContext(..), inHsDocContext, withHsDocContext
-                         , mapFvRn, pprHsDocContext, bindLocalNamesFV
+import GHC.Rename.Utils  ( mapFvRn, bindLocalNamesFV
                          , typeAppErr, newLocalBndrRn, checkDupRdrNamesN
                          , checkShadowedRdrNames, warnForallIdentifier )
 import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn
                          , lookupTyFixityRn )
 import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) )
 import GHC.Tc.Errors.Types
-import GHC.Tc.Errors.Ppr ( pprScopeError )
+import GHC.Tc.Errors.Ppr ( pprScopeError
+                         , inHsDocContext, withHsDocContext, pprHsDocContext )
 import GHC.Tc.Utils.Monad
 import GHC.Types.Name.Reader
 import GHC.Builtin.Names
@@ -291,10 +291,11 @@ checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM ()
 -- Check that extra-constraints are allowed at all, and
 -- if so that it's an anonymous wildcard
 checkExtraConstraintWildCard env hs_ctxt
-  = checkWildCard env mb_bad
+  = checkWildCard env Nothing mb_bad
   where
     mb_bad | not (extraConstraintWildCardsAllowed env)
-           = Just base_msg
+           = Just $ ExtraConstraintWildcardNotAllowed
+                      SoleExtraConstraintWildcardNotAllowed
              -- Currently, we do not allow wildcards in their full glory in
              -- standalone deriving declarations. We only allow a single
              -- extra-constraints wildcard à la:
@@ -306,18 +307,11 @@ checkExtraConstraintWildCard env hs_ctxt
              --   deriving instance (Eq a, _) => Eq (Foo a)
            | DerivDeclCtx {} <- rtke_ctxt env
            , not (null hs_ctxt)
-           = Just deriv_decl_msg
+           = Just $ ExtraConstraintWildcardNotAllowed
+                      SoleExtraConstraintWildcardAllowed
            | otherwise
            = Nothing
 
-    base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard
-                   <+> text "not allowed"
-
-    deriv_decl_msg
-      = hang base_msg
-           2 (vcat [ text "except as the sole constraint"
-                   , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ])
-
 extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
 extraConstraintWildCardsAllowed env
   = case rtke_ctxt env of
@@ -840,46 +834,39 @@ rnHsTyOp env overall_ty (L loc op)
        ; return (l_op', unitFV op') }
 
 --------------
-notAllowed :: SDoc -> SDoc
-notAllowed doc
-  = text "Wildcard" <+> quotes doc <+> text "not allowed"
-
-checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM ()
-checkWildCard env (Just doc)
-  = addErr $ TcRnUnknownMessage $ mkPlainError noHints $
-     vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))]
-checkWildCard _ Nothing
+checkWildCard :: RnTyKiEnv
+              -> Maybe Name -- ^ name of the wildcard,
+                            -- or 'Nothing' for an anonymous wildcard
+              -> Maybe BadAnonWildcardContext
+              -> RnM ()
+checkWildCard env mb_name (Just bad)
+  = addErr $ TcRnIllegalWildcardInType mb_name bad (Just $ rtke_ctxt env)
+checkWildCard _ _ Nothing
   = return ()
 
 checkAnonWildCard :: RnTyKiEnv -> RnM ()
 -- Report an error if an anonymous wildcard is illegal here
 checkAnonWildCard env
-  = checkWildCard env mb_bad
+  = checkWildCard env Nothing mb_bad
   where
-    mb_bad :: Maybe SDoc
+    mb_bad :: Maybe BadAnonWildcardContext
     mb_bad | not (wildCardsAllowed env)
-           = Just (notAllowed pprAnonWildCard)
+           = Just WildcardsNotAllowedAtAll
            | otherwise
            = case rtke_what env of
                RnTypeBody      -> Nothing
-               RnTopConstraint -> Just constraint_msg
-               RnConstraint    -> Just constraint_msg
-
-    constraint_msg = hang
-                         (notAllowed pprAnonWildCard <+> text "in a constraint")
-                        2 hint_msg
-    hint_msg = vcat [ text "except as the last top-level constraint of a type signature"
-                    , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]
+               RnTopConstraint -> Just WildcardNotLastInConstraint
+               RnConstraint    -> Just WildcardNotLastInConstraint
 
 checkNamedWildCard :: RnTyKiEnv -> Name -> RnM ()
 -- Report an error if a named wildcard is illegal here
 checkNamedWildCard env name
-  = checkWildCard env mb_bad
+  = checkWildCard env (Just name) mb_bad
   where
     mb_bad | not (name `elemNameSet` rtke_nwcs env)
            = Nothing  -- Not a wildcard
            | not (wildCardsAllowed env)
-           = Just (notAllowed (ppr name))
+           = Just WildcardsNotAllowedAtAll
            | otherwise
            = case rtke_what env of
                RnTypeBody      -> Nothing   -- Allowed
@@ -887,8 +874,7 @@ checkNamedWildCard env name
                   -- f :: (Eq _a) => _a -> Int
                   -- g :: (_a, _b) => T _a _b -> Int
                   -- The named tyvars get filled in from elsewhere
-               RnConstraint    -> Just constraint_msg
-    constraint_msg = notAllowed (ppr name) <+> text "in a constraint"
+               RnConstraint    -> Just WildcardNotLastInConstraint
 
 wildCardsAllowed :: RnTyKiEnv -> Bool
 -- ^ In what contexts are wildcards permitted
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 85f7467565..94864e8478 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -28,15 +28,16 @@ import GHC.Types.Name.Reader
 import GHC.Rename.HsType
 import GHC.Rename.Bind
 import GHC.Rename.Env
-import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames
+import GHC.Rename.Utils ( mapFvRn, bindLocalNames
                         , checkDupRdrNamesN, bindLocalNamesFV
                         , checkShadowedRdrNames, warnUnusedTypePatterns
                         , newLocalBndrsRn
-                        , withHsDocContext, noNestedForallsContextsErr
+                        , noNestedForallsContextsErr
                         , addNoNestedForallsContextsErr, checkInferredVars, warnForallIdentifier )
 import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) )
 import GHC.Rename.Names
 import GHC.Tc.Errors.Types
+import GHC.Tc.Errors.Ppr (withHsDocContext)
 import GHC.Tc.Gen.Annotation ( annCtxt )
 import GHC.Tc.Utils.Monad
 
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 0f78a86b57..9eeaff6783 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -52,7 +52,7 @@ import GHC.Tc.Utils.Monad
 import GHC.Tc.Utils.Zonk   ( hsOverLitName )
 import GHC.Rename.Env
 import GHC.Rename.Fixity
-import GHC.Rename.Utils    ( HsDocContext(..), newLocalBndrRn, bindLocalNames
+import GHC.Rename.Utils    ( newLocalBndrRn, bindLocalNames
                            , warnUnusedMatches, newLocalBndrRn
                            , checkUnusedRecordWildcard
                            , checkDupNames, checkDupAndShadowedNames
diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs
index 97f5b2c2eb..54087c5b4e 100644
--- a/compiler/GHC/Rename/Splice.hs
+++ b/compiler/GHC/Rename/Splice.hs
@@ -22,7 +22,7 @@ import GHC.Tc.Utils.Monad
 import GHC.Driver.Env.Types
 
 import GHC.Rename.Env
-import GHC.Rename.Utils   ( HsDocContext(..), newLocalBndrRn )
+import GHC.Rename.Utils   ( newLocalBndrRn )
 import GHC.Rename.Unbound ( isUnboundName )
 import GHC.Rename.Module  ( rnSrcDecls, findSplice )
 import GHC.Rename.Pat     ( rnPat )
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index 1647c19e32..597af3d778 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -21,8 +21,6 @@ module GHC.Rename.Utils (
         badQualBndrErr, typeAppErr, badFieldConErr,
         wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType,
         genHsIntegralLit, genHsTyLit,
-        HsDocContext(..), pprHsDocContext,
-        inHsDocContext, withHsDocContext,
 
         newLocalBndrRn, newLocalBndrsRn,
 
@@ -43,6 +41,7 @@ import GHC.Core.Type
 import GHC.Hs
 import GHC.Types.Name.Reader
 import GHC.Tc.Errors.Types
+import GHC.Tc.Errors.Ppr (withHsDocContext)
 import GHC.Tc.Utils.Env
 import GHC.Tc.Utils.Monad
 import GHC.Types.Error
@@ -677,72 +676,3 @@ genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit)
 
 genHsTyLit :: FastString -> HsType GhcRn
 genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Contexts for renaming errors}
-*                                                                      *
-************************************************************************
--}
-
--- AZ:TODO: Change these all to be Name instead of RdrName.
---          Merge TcType.UserTypeContext in to it.
-data HsDocContext
-  = TypeSigCtx SDoc
-  | StandaloneKindSigCtx SDoc
-  | PatCtx
-  | SpecInstSigCtx
-  | DefaultDeclCtx
-  | ForeignDeclCtx (LocatedN RdrName)
-  | DerivDeclCtx
-  | RuleCtx FastString
-  | TyDataCtx (LocatedN RdrName)
-  | TySynCtx (LocatedN RdrName)
-  | TyFamilyCtx (LocatedN RdrName)
-  | FamPatCtx (LocatedN RdrName)    -- The patterns of a type/data family instance
-  | ConDeclCtx [LocatedN Name]
-  | ClassDeclCtx (LocatedN RdrName)
-  | ExprWithTySigCtx
-  | TypBrCtx
-  | HsTypeCtx
-  | HsTypePatCtx
-  | GHCiCtx
-  | SpliceTypeCtx (LHsType GhcPs)
-  | ClassInstanceCtx
-  | GenericCtx SDoc   -- Maybe we want to use this more!
-
-withHsDocContext :: HsDocContext -> SDoc -> SDoc
-withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt
-
-inHsDocContext :: HsDocContext -> SDoc
-inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt
-
-pprHsDocContext :: HsDocContext -> SDoc
-pprHsDocContext (GenericCtx doc)      = doc
-pprHsDocContext (TypeSigCtx doc)      = text "the type signature for" <+> doc
-pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc
-pprHsDocContext PatCtx                = text "a pattern type-signature"
-pprHsDocContext SpecInstSigCtx        = text "a SPECIALISE instance pragma"
-pprHsDocContext DefaultDeclCtx        = text "a `default' declaration"
-pprHsDocContext DerivDeclCtx          = text "a deriving declaration"
-pprHsDocContext (RuleCtx name)        = text "the rewrite rule" <+> doubleQuotes (ftext name)
-pprHsDocContext (TyDataCtx tycon)     = text "the data type declaration for" <+> quotes (ppr tycon)
-pprHsDocContext (FamPatCtx tycon)     = text "a type pattern of family instance for" <+> quotes (ppr tycon)
-pprHsDocContext (TySynCtx name)       = text "the declaration for type synonym" <+> quotes (ppr name)
-pprHsDocContext (TyFamilyCtx name)    = text "the declaration for type family" <+> quotes (ppr name)
-pprHsDocContext (ClassDeclCtx name)   = text "the declaration for class" <+> quotes (ppr name)
-pprHsDocContext ExprWithTySigCtx      = text "an expression type signature"
-pprHsDocContext TypBrCtx              = text "a Template-Haskell quoted type"
-pprHsDocContext HsTypeCtx             = text "a type argument"
-pprHsDocContext HsTypePatCtx          = text "a type argument in a pattern"
-pprHsDocContext GHCiCtx               = text "GHCi input"
-pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty)
-pprHsDocContext ClassInstanceCtx      = text "GHC.Tc.Gen.Splice.reifyInstances"
-
-pprHsDocContext (ForeignDeclCtx name)
-   = text "the foreign declaration for" <+> quotes (ppr name)
-pprHsDocContext (ConDeclCtx [name])
-   = text "the definition of data constructor" <+> quotes (ppr name)
-pprHsDocContext (ConDeclCtx names)
-   = text "the definition of data constructors" <+> interpp'SP names