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

5 files changed, 227 insertions, 6 deletions

diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index a736a40871..2e535338e6 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -10,6 +10,10 @@ module GHC.Tc.Errors.Ppr
   --
   , tidySkolemInfo
   , tidySkolemInfoAnon
+  --
+  , withHsDocContext
+  , pprHsDocContext
+  , inHsDocContext
   )
   where
 
@@ -164,6 +168,53 @@ instance Diagnostic TcRnMessage where
       -> mkSimpleDecorated $ text "Illegal use of punning for field" <+> quotes (ppr fld)
     TcRnIllegalWildcardsInRecord fld_part
       -> mkSimpleDecorated $ text "Illegal `..' in record" <+> pprRecordFieldPart fld_part
+    TcRnIllegalWildcardInType mb_name bad mb_ctxt
+      -> mkSimpleDecorated $ vcat [ main_msg, context_msg ]
+      where
+        main_msg :: SDoc
+        main_msg = case bad of
+          WildcardNotLastInConstraint ->
+            hang notAllowed 2 constraint_hint_msg
+          ExtraConstraintWildcardNotAllowed allow_sole ->
+            case allow_sole of
+              SoleExtraConstraintWildcardNotAllowed ->
+                notAllowed
+              SoleExtraConstraintWildcardAllowed ->
+                hang notAllowed 2 sole_msg
+          WildcardsNotAllowedAtAll ->
+            notAllowed
+        context_msg :: SDoc
+        context_msg = case mb_ctxt of
+          Just ctxt -> nest 2 (text "in" <+> pprHsDocContext ctxt)
+          _         -> empty
+        notAllowed, what, wildcard, how :: SDoc
+        notAllowed = what <+> quotes wildcard <+> how
+        wildcard = case mb_name of
+          Nothing   -> pprAnonWildCard
+          Just name -> ppr name
+        what
+          | Just _ <- mb_name
+          = text "Named wildcard"
+          | ExtraConstraintWildcardNotAllowed {} <- bad
+          = text "Extra-constraint wildcard"
+          | otherwise
+          = text "Wildcard"
+        how = case bad of
+          WildcardNotLastInConstraint
+            -> text "not allowed in a constraint"
+          _ -> text "not allowed"
+        constraint_hint_msg :: SDoc
+        constraint_hint_msg
+          | Just _ <- mb_name
+          = vcat [ text "Extra-constraint wildcards must be anonymous"
+                 , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]
+          | otherwise
+          = vcat [ text "except as the last top-level constraint of a type signature"
+                 , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]
+        sole_msg :: SDoc
+        sole_msg =
+          vcat [ text "except as the sole constraint"
+               , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ]
     TcRnDuplicateFieldName fld_part dups
       -> mkSimpleDecorated $
            hsep [text "duplicate field name",
@@ -691,6 +742,8 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnIllegalWildcardsInRecord{}
       -> ErrorWithoutFlag
+    TcRnIllegalWildcardInType{}
+      -> ErrorWithoutFlag
     TcRnDuplicateFieldName{}
       -> ErrorWithoutFlag
     TcRnIllegalViewPattern{}
@@ -927,6 +980,8 @@ instance Diagnostic TcRnMessage where
       -> [suggestExtension LangExt.NamedFieldPuns]
     TcRnIllegalWildcardsInRecord{}
       -> [suggestExtension LangExt.RecordWildCards]
+    TcRnIllegalWildcardInType{}
+      -> noHints
     TcRnDuplicateFieldName{}
       -> noHints
     TcRnIllegalViewPattern{}
@@ -2811,3 +2866,46 @@ expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret)
     sameShapes (CastTy ty1 _)   ty2              = sameShapes ty1 ty2
     sameShapes ty1              (CastTy ty2 _)   = sameShapes ty1 ty2
     sameShapes _                _                = False
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Contexts for renaming errors}
+*                                                                      *
+************************************************************************
+-}
+
+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
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 713232686f..d6004c7b96 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -26,6 +26,8 @@ module GHC.Tc.Errors.Types (
   , DeriveInstanceBadConstructor(..)
   , HasWildcard(..)
   , hasWildcard
+  , BadAnonWildcardContext(..)
+  , SoleExtraConstraintWildcardAllowed(..)
   , DeriveGenericsErrReason(..)
   , HasAssociatedDataFamInsts(..)
   , hasAssociatedDataFamInsts
@@ -35,6 +37,7 @@ module GHC.Tc.Errors.Types (
   , associatedTyNotParamOverLastTyVar
   , MissingSignature(..)
   , Exported(..)
+  , HsDocContext(..)
 
   , ErrorItem(..), errorItemOrigin, errorItemEqRel, errorItemPred, errorItemCtLoc
 
@@ -92,6 +95,7 @@ import GHC.Unit.Module.Name (ModuleName)
 import GHC.Types.Basic
 import GHC.Utils.Misc (filterOut)
 import qualified GHC.LanguageExtensions as LangExt
+import GHC.Data.FastString (FastString)
 
 import qualified Data.List.NonEmpty as NE
 import           Data.Typeable hiding (TyCon)
@@ -426,6 +430,69 @@ data TcRnMessage where
   -}
   TcRnIllegalWildcardsInRecord :: !RecordFieldPart -> TcRnMessage
 
+  {-| TcRnIllegalWildcardInType is an error that occurs
+      when a wildcard appears in a type in a location in which
+      wildcards aren't allowed.
+
+      Examples:
+
+        Type synonyms:
+
+          type T = _
+
+        Class declarations and instances:
+
+          class C _
+          instance C _
+
+        Standalone kind signatures:
+
+          type D :: _
+          data D
+
+      Test cases:
+        ExtraConstraintsWildcardInTypeSplice2
+        ExtraConstraintsWildcardInTypeSpliceUsed
+        ExtraConstraintsWildcardNotLast
+        ExtraConstraintsWildcardTwice
+        NestedExtraConstraintsWildcard
+        NestedNamedExtraConstraintsWildcard
+        PartialClassMethodSignature
+        PartialClassMethodSignature2
+        T12039
+        T13324_fail1
+        UnnamedConstraintWildcard1
+        UnnamedConstraintWildcard2
+        WildcardInADT1
+        WildcardInADT2
+        WildcardInADT3
+        WildcardInADTContext1
+        WildcardInDefault
+        WildcardInDefaultSignature
+        WildcardInDeriving
+        WildcardInForeignExport
+        WildcardInForeignImport
+        WildcardInGADT1
+        WildcardInGADT2
+        WildcardInInstanceHead
+        WildcardInInstanceSig
+        WildcardInNewtype
+        WildcardInPatSynSig
+        WildcardInStandaloneDeriving
+        WildcardInTypeFamilyInstanceRHS
+        WildcardInTypeSynonymRHS
+        saks_fail003
+        T15433a
+  -}
+
+  TcRnIllegalWildcardInType
+    :: Maybe Name
+        -- ^ the wildcard name, or 'Nothing' for an anonymous wildcard
+    -> !BadAnonWildcardContext
+    -> !(Maybe HsDocContext)
+    -> TcRnMessage
+
+
   {-| TcRnDuplicateFieldName is an error that occurs whenever
       there are duplicate field names in a record.
 
@@ -1812,6 +1879,19 @@ hasWildcard :: Bool -> HasWildcard
 hasWildcard True  = YesHasWildcard
 hasWildcard False = NoHasWildcard
 
+-- | A context in which we don't allow anonymous wildcards.
+data BadAnonWildcardContext
+  = WildcardNotLastInConstraint
+  | ExtraConstraintWildcardNotAllowed
+      SoleExtraConstraintWildcardAllowed
+  | WildcardsNotAllowedAtAll
+
+-- | Whether a sole extra-constraint wildcard is allowed,
+-- e.g. @_ => ..@ as opposed to @( .., _ ) => ..@.
+data SoleExtraConstraintWildcardAllowed
+  = SoleExtraConstraintWildcardNotAllowed
+  | SoleExtraConstraintWildcardAllowed
+
 -- | A type representing whether or not the input type has associated data family instances.
 data HasAssociatedDataFamInsts
   = YesHasAdfs
@@ -2483,3 +2563,38 @@ pprRelevantBindings (RelevantBindings bds ran_out_of_fuel) =
 discardMsg :: SDoc
 discardMsg = text "(Some bindings suppressed;" <+>
              text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)"
+
+
+{-
+************************************************************************
+*                                                                      *
+\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
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index 4463d25590..de16c657fd 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -2231,10 +2231,20 @@ tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }
                      HM_VTA     -> False
                      HM_TyAppPat -> False
 
-tcAnonWildCardOcc _ mode ty _
--- mode_holes is Nothing.  Should not happen, because renamer
--- should already have rejected holes in unexpected places
-  = pprPanic "tcWildCardOcc" (ppr mode $$ ppr ty)
+tcAnonWildCardOcc is_extra _ _ _
+-- mode_holes is Nothing. This means we have an anonymous wildcard
+-- in an unexpected place. The renamer rejects these wildcards in 'checkAnonWildcard',
+-- but it is possible for a wildcard to be introduced by a Template Haskell splice,
+-- as per #15433. To account for this, we throw a generic catch-all error message.
+  = failWith $ TcRnIllegalWildcardInType Nothing reason Nothing
+    where
+      reason =
+        case is_extra of
+          YesExtraConstraint ->
+            ExtraConstraintWildcardNotAllowed
+              SoleExtraConstraintWildcardNotAllowed
+          NoExtraConstraint  ->
+            WildcardsNotAllowedAtAll
 
 {- Note [Wildcard names]
 ~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index f2efb93f2d..2be524e1fc 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -83,7 +83,6 @@ import GHC.Runtime.Interpreter
 import GHC.Rename.Splice( traceSplice, SpliceInfo(..))
 import GHC.Rename.Expr
 import GHC.Rename.Env
-import GHC.Rename.Utils  ( HsDocContext(..) )
 import GHC.Rename.Fixity ( lookupFixityRn_help )
 import GHC.Rename.HsType
 
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 11278d6bc7..aa43b7e4e0 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -91,7 +91,6 @@ import GHC.Tc.Utils.Backpack
 import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
 import GHC.Rename.HsType
 import GHC.Rename.Expr
-import GHC.Rename.Utils  ( HsDocContext(..) )
 import GHC.Rename.Fixity ( lookupFixityRn )
 import GHC.Rename.Names
 import GHC.Rename.Env