Make warnings for TH splices opt-inwip/T17270

In #17270 we have the pattern-match checker emit incorrect warnings. The
reason for that behavior is ultimately an inconsistency in whether we
treat TH splices as written by the user (`FromSource :: Origin`) or as
generated code (`Generated`). This was first reported in #14838.

The current solution is to TH splices as `Generated` by default and only
treat them as `FromSource` when the user requests so
(-fenable-th-splice-warnings). There are multiple reasons for opt-in
rather than opt-out:

  * It's not clear that the user that compiles a splice is the author of the code
    that produces the warning. Think of the situation where she just splices in
    code from a third-party library that produces incomplete pattern matches.
    In this scenario, the user isn't even able to fix that warning.
  * Gathering information for producing the warnings (pattern-match check
    warnings in particular) is costly. There's no point in doing so if the user
    is not interested in those warnings.

Fixes #17270, but not #14838, because the proper solution needs a GHC
proposal extending the TH AST syntax.

10 files changed, 168 insertions, 88 deletions

diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 92b9290fb1..bac4dff9d9 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -48,7 +48,7 @@ module GHC.Hs.Utils(
   mkChunkified, chunkify,
 
   -- * Bindings
-  mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
+  mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind,
   mkPatSynBind,
   isInfixFunBind,
 
@@ -800,14 +800,15 @@ l
 ************************************************************************
 -}
 
-mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
+mkFunBind :: Origin -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
           -> HsBind GhcPs
 -- ^ Not infix, with place holders for coercion and free vars
-mkFunBind fn ms = FunBind { fun_id = fn
-                          , fun_matches = mkMatchGroup Generated ms
-                          , fun_co_fn = idHsWrapper
-                          , fun_ext = noExtField
-                          , fun_tick = [] }
+mkFunBind origin fn ms
+  = FunBind { fun_id = fn
+            , fun_matches = mkMatchGroup origin ms
+            , fun_co_fn = idHsWrapper
+            , fun_ext = noExtField
+            , fun_tick = [] }
 
 mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]
              -> HsBind GhcRn
@@ -820,7 +821,7 @@ mkTopFunBind origin fn ms = FunBind { fun_id = fn
                                     , fun_tick = [] }
 
 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
-mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
+mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs
 
 mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
 mkVarBind var rhs = cL (getLoc rhs) $
@@ -846,10 +847,12 @@ isInfixFunBind _ = False
 
 
 ------------
-mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
+-- | Convenience function using 'mkFunBind'.
+-- This is for generated bindings only, do not use for user-written code.
+mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
                 -> LHsExpr GhcPs -> LHsBind GhcPs
-mk_easy_FunBind loc fun pats expr
-  = cL loc $ mkFunBind (cL loc fun)
+mkSimpleGeneratedFunBind loc fun pats expr
+  = cL loc $ mkFunBind Generated (cL loc fun)
               [mkMatch (mkPrefixFunRhs (cL loc fun)) pats expr
                        (noLoc emptyLocalBinds)]
 
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 7d913ff4bf..ed6238e8de 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -58,27 +58,28 @@ import System.IO.Unsafe
 -------------------------------------------------------------------
 --              The external interface
 
-convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]
-convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds))
+convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]
+convertToHsDecls origin loc ds = initCvt origin loc (fmap catMaybes (mapM cvt_dec ds))
   where
     cvt_dec d = wrapMsg "declaration" d (cvtDec d)
 
-convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)
-convertToHsExpr loc e
-  = initCvt loc $ wrapMsg "expression" e $ cvtl e
+convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)
+convertToHsExpr origin loc e
+  = initCvt origin loc $ wrapMsg "expression" e $ cvtl e
 
-convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)
-convertToPat loc p
-  = initCvt loc $ wrapMsg "pattern" p $ cvtPat p
+convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)
+convertToPat origin loc p
+  = initCvt origin loc $ wrapMsg "pattern" p $ cvtPat p
 
-convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)
-convertToHsType loc t
-  = initCvt loc $ wrapMsg "type" t $ cvtType t
+convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)
+convertToHsType origin loc t
+  = initCvt origin loc $ wrapMsg "type" t $ cvtType t
 
 -------------------------------------------------------------------
-newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
+newtype CvtM a = CvtM { unCvtM :: Origin -> SrcSpan -> Either MsgDoc (SrcSpan, a) }
     deriving (Functor)
-        -- Push down the source location;
+        -- Push down the Origin (that is configurable by
+        -- -fenable-th-splice-warnings) and source location;
         -- Can fail, with a single error message
 
 -- NB: If the conversion succeeds with (Right x), there should
@@ -91,45 +92,48 @@ newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
 -- the spliced-in declarations get a location that at least relates to the splice point
 
 instance Applicative CvtM where
-    pure x = CvtM $ \loc -> Right (loc,x)
+    pure x = CvtM $ \_ loc -> Right (loc,x)
     (<*>) = ap
 
 instance Monad CvtM where
-  (CvtM m) >>= k = CvtM $ \loc -> case m loc of
-                                  Left err -> Left err
-                                  Right (loc',v) -> unCvtM (k v) loc'
+  (CvtM m) >>= k = CvtM $ \origin loc -> case m origin loc of
+    Left err -> Left err
+    Right (loc',v) -> unCvtM (k v) origin loc'
 
-initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a
-initCvt loc (CvtM m) = fmap snd (m loc)
+initCvt :: Origin -> SrcSpan -> CvtM a -> Either MsgDoc a
+initCvt origin loc (CvtM m) = fmap snd (m origin loc)
 
 force :: a -> CvtM ()
 force a = a `seq` return ()
 
 failWith :: MsgDoc -> CvtM a
-failWith m = CvtM (\_ -> Left m)
+failWith m = CvtM (\_ _ -> Left m)
+
+getOrigin :: CvtM Origin
+getOrigin = CvtM (\origin loc -> Right (loc,origin))
 
 getL :: CvtM SrcSpan
-getL = CvtM (\loc -> Right (loc,loc))
+getL = CvtM (\_ loc -> Right (loc,loc))
 
 setL :: SrcSpan -> CvtM ()
-setL loc = CvtM (\_ -> Right (loc, ()))
+setL loc = CvtM (\_ _ -> Right (loc, ()))
 
 returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a
-returnL x = CvtM (\loc -> Right (loc, cL loc x))
+returnL x = CvtM (\_ loc -> Right (loc, cL loc x))
 
 returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
 returnJustL = fmap Just . returnL
 
 wrapParL :: HasSrcSpan a =>
             (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess  a)
-wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (cL loc x)))
+wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (cL loc x)))
 
 wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
 -- E.g  wrapMsg "declaration" dec thing
 wrapMsg what item (CvtM m)
-  = CvtM (\loc -> case m loc of
-                     Left err -> Left (err $$ getPprStyle msg)
-                     Right v  -> Right v)
+  = CvtM $ \origin loc -> case m origin loc of
+      Left err -> Left (err $$ getPprStyle msg)
+      Right v  -> Right v
   where
         -- Show the item in pretty syntax normally,
         -- but with all its constructors if you say -dppr-debug
@@ -139,9 +143,9 @@ wrapMsg what item (CvtM m)
                     else text (pprint item))
 
 wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
-wrapL (CvtM m) = CvtM (\loc -> case m loc of
-                               Left err -> Left err
-                               Right (loc',v) -> Right (loc',cL loc v))
+wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of
+  Left err -> Left err
+  Right (loc',v) -> Right (loc',cL loc v)
 
 -------------------------------------------------------------------
 cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]
@@ -152,7 +156,8 @@ cvtDec (TH.ValD pat body ds)
   | TH.VarP s <- pat
   = do  { s' <- vNameL s
         ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)
-        ; returnJustL $ Hs.ValD noExtField $ mkFunBind s' [cl'] }
+        ; th_origin <- getOrigin
+        ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin s' [cl'] }
 
   | otherwise
   = do  { pat' <- cvtPat pat
@@ -172,7 +177,8 @@ cvtDec (TH.FunD nm cls)
   | otherwise
   = do  { nm' <- vNameL nm
         ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
-        ; returnJustL $ Hs.ValD noExtField $ mkFunBind nm' cls' }
+        ; th_origin <- getOrigin
+        ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin nm' cls' }
 
 cvtDec (TH.SigD nm typ)
   = do  { nm' <- vNameL nm
@@ -403,7 +409,8 @@ cvtDec (TH.PatSynD nm args dir pat)
     cvtDir _ ImplBidir       = return ImplicitBidirectional
     cvtDir n (ExplBidir cls) =
       do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls
-         ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }
+         ; th_origin <- getOrigin
+         ; return $ ExplicitBidirectional $ mkMatchGroup th_origin ms }
 
 cvtDec (TH.PatSynSigD nm ty)
   = do { nm' <- cNameL nm
@@ -464,8 +471,6 @@ cvt_ci_decs doc decs
         ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'
         ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'
         ; unless (null bads) (failWith (mkBadDecMsg doc bads))
-          --We use FromSource as the origin of the bind
-          -- because the TH declaration is user-written
         ; return (listToBag binds', sigs', fams', ats', adts') }
 
 ----------------
@@ -901,12 +906,14 @@ cvtl e = wrapL (cvt e)
                                -- lambda expressions. See #13856.
     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
                             ; let pats = map (parenthesizePat appPrec) ps'
-                            ; return $ HsLam noExtField (mkMatchGroup FromSource
+                            ; th_origin <- getOrigin
+                            ; return $ HsLam noExtField (mkMatchGroup th_origin
                                              [mkSimpleMatch LambdaExpr
                                              pats e'])}
     cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch CaseAlt) ms
+                            ; th_origin <- getOrigin
                             ; return $ HsLamCase noExtField
-                                                   (mkMatchGroup FromSource ms')
+                                                   (mkMatchGroup th_origin ms')
                             }
     cvt (TupE es)        = cvt_tup es Boxed
     cvt (UnboxedTupE es) = cvt_tup es Unboxed
@@ -923,8 +930,9 @@ cvtl e = wrapL (cvt e)
     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (text "a let expression") ds
                             ; e' <- cvtl e; return $ HsLet noExtField (noLoc ds') e'}
     cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
+                            ; th_origin <- getOrigin
                             ; return $ HsCase noExtField e'
-                                                 (mkMatchGroup FromSource ms') }
+                                                 (mkMatchGroup th_origin ms') }
     cvt (DoE ss)       = cvtHsDo DoExpr ss
     cvt (MDoE ss)      = cvtHsDo MDoExpr ss
     cvt (CompE ss)     = cvtHsDo ListComp ss
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 70f50f2a8b..d86c064ba8 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -557,6 +557,7 @@ data GeneralFlag
    | Opt_UnboxSmallStrictFields
    | Opt_DictsCheap
    | Opt_EnableRewriteRules             -- Apply rewrite rules during simplification
+   | Opt_EnableThSpliceWarnings         -- Enable warnings for TH splices
    | Opt_RegsGraph                      -- do graph coloring register allocation
    | Opt_RegsIterative                  -- do iterative coalescing graph coloring register allocation
    | Opt_PedanticBottoms                -- Be picky about how we treat bottom
@@ -4208,6 +4209,7 @@ fFlagsDeps = [
   flagSpec "eager-blackholing"                Opt_EagerBlackHoling,
   flagSpec "embed-manifest"                   Opt_EmbedManifest,
   flagSpec "enable-rewrite-rules"             Opt_EnableRewriteRules,
+  flagSpec "enable-th-splice-warnings"        Opt_EnableThSpliceWarnings,
   flagSpec "error-spans"                      Opt_ErrorSpans,
   flagSpec "excess-precision"                 Opt_ExcessPrecision,
   flagSpec "expose-all-unfoldings"            Opt_ExposeAllUnfoldings,
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 8eb86fcec2..add22a6060 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -358,11 +358,11 @@ gen_Ord_binds loc tycon = do
       = emptyBag
 
     negate_expr = nlHsApp (nlHsVar not_RDR)
-    lE = mk_easy_FunBind loc le_RDR [a_Pat, b_Pat] $
+    lE = mkSimpleGeneratedFunBind loc le_RDR [a_Pat, b_Pat] $
         negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr)
-    gT = mk_easy_FunBind loc gt_RDR [a_Pat, b_Pat] $
+    gT = mkSimpleGeneratedFunBind loc gt_RDR [a_Pat, b_Pat] $
         nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr
-    gE = mk_easy_FunBind loc ge_RDR [a_Pat, b_Pat] $
+    gE = mkSimpleGeneratedFunBind loc ge_RDR [a_Pat, b_Pat] $
         negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr)
 
     get_tag con = dataConTag con - fIRST_TAG
@@ -381,7 +381,7 @@ gen_Ord_binds loc tycon = do
 
     mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs
     -- Returns a binding   op a b = ... compares a and b according to op ....
-    mkOrdOp dflags op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat]
+    mkOrdOp dflags op = mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat]
                                         (mkOrdOpRhs dflags op)
 
     mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs
@@ -597,7 +597,7 @@ gen_Enum_binds loc tycon = do
     occ_nm = getOccString tycon
 
     succ_enum dflags
-      = mk_easy_FunBind loc succ_RDR [a_Pat] $
+      = mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $
         untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
         nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon),
                                nlHsVarApps intDataCon_RDR [ah_RDR]])
@@ -607,7 +607,7 @@ gen_Enum_binds loc tycon = do
                                         nlHsIntLit 1]))
 
     pred_enum dflags
-      = mk_easy_FunBind loc pred_RDR [a_Pat] $
+      = mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $
         untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
         nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
                                nlHsVarApps intDataCon_RDR [ah_RDR]])
@@ -619,7 +619,7 @@ gen_Enum_binds loc tycon = do
                                                 (mkIntegralLit (-1 :: Int)))]))
 
     to_enum dflags
-      = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
+      = mkSimpleGeneratedFunBind loc toEnum_RDR [a_Pat] $
         nlHsIf (nlHsApps and_RDR
                 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
                  nlHsApps le_RDR [ nlHsVar a_RDR
@@ -628,7 +628,7 @@ gen_Enum_binds loc tycon = do
              (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon))
 
     enum_from dflags
-      = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
+      = mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $
           untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
           nlHsApps map_RDR
                 [nlHsVar (tag2con_RDR dflags tycon),
@@ -637,7 +637,7 @@ gen_Enum_binds loc tycon = do
                             (nlHsVar (maxtag_RDR dflags tycon)))]
 
     enum_from_then dflags
-      = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
+      = mkSimpleGeneratedFunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
           untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
             nlHsPar (enum_from_then_to_Expr
@@ -650,7 +650,7 @@ gen_Enum_binds loc tycon = do
                            ))
 
     from_enum dflags
-      = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
+      = mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $
           untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
           (nlHsVarApps intDataCon_RDR [ah_RDR])
 
@@ -766,7 +766,7 @@ gen_Ix_binds loc tycon = do
       ]
 
     enum_range dflags
-      = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
+      = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
           untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
           untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
@@ -775,7 +775,7 @@ gen_Ix_binds loc tycon = do
                         (nlHsVarApps intDataCon_RDR [bh_RDR]))
 
     enum_index dflags
-      = mk_easy_FunBind loc unsafeIndex_RDR
+      = mkSimpleGeneratedFunBind loc unsafeIndex_RDR
                 [noLoc (AsPat noExtField (noLoc c_RDR)
                            (nlTuplePat [a_Pat, nlWildPat] Boxed)),
                                 d_Pat] (
@@ -792,7 +792,7 @@ gen_Ix_binds loc tycon = do
 
     -- This produces something like `(ch >= ah) && (ch <= bh)`
     enum_inRange dflags
-      = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
+      = mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
           untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
           untag_Expr dflags tycon [(b_RDR, bh_RDR)] (
           untag_Expr dflags tycon [(c_RDR, ch_RDR)] (
@@ -825,7 +825,7 @@ gen_Ix_binds loc tycon = do
 
     --------------------------------------------------------------
     single_con_range
-      = mk_easy_FunBind loc range_RDR
+      = mkSimpleGeneratedFunBind loc range_RDR
           [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
         noLoc (mkHsComp ListComp stmts con_expr)
       where
@@ -837,7 +837,7 @@ gen_Ix_binds loc tycon = do
 
     ----------------
     single_con_index
-      = mk_easy_FunBind loc unsafeIndex_RDR
+      = mkSimpleGeneratedFunBind loc unsafeIndex_RDR
                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
                  con_pat cs_needed]
         -- We need to reverse the order we consider the components in
@@ -863,7 +863,7 @@ gen_Ix_binds loc tycon = do
 
     ------------------
     single_con_inRange
-      = mk_easy_FunBind loc inRange_RDR
+      = mkSimpleGeneratedFunBind loc inRange_RDR
                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
                  con_pat cs_needed] $
           if con_arity == 0
@@ -1380,7 +1380,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
                      mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
 
         ------------ gunfold
-    gunfold_bind = mk_easy_FunBind loc
+    gunfold_bind = mkSimpleGeneratedFunBind loc
                      gunfold_RDR
                      [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat]
                      gunfold_rhs
@@ -1409,7 +1409,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
     to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)
 
         ------------ dataTypeOf
-    dataTypeOf_bind = mk_easy_FunBind
+    dataTypeOf_bind = mkSimpleGeneratedFunBind
                         loc
                         dataTypeOf_RDR
                         [nlWildPat]
@@ -1436,7 +1436,7 @@ gen_data dflags data_type_name constr_names loc rep_tc
                 | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
                 | otherwise                 = emptyBag
     mk_gcast dataCast_RDR gcast_RDR
-      = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
+      = unitBag (mkSimpleGeneratedFunBind loc dataCast_RDR [nlVarPat f_RDR]
                                  (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
 
 
@@ -2019,7 +2019,7 @@ mkFunBindSE arity loc fun pats_and_exprs
 mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
              -> LHsBind GhcPs
 mkRdrFunBind fun@(L loc _fun_rdr) matches
-  = L loc (mkFunBind fun matches)
+  = L loc (mkFunBind Generated fun matches)
 
 -- | Make a function binding. If no equations are given, produce a function
 -- with the given arity that uses an empty case expression for the last
@@ -2047,7 +2047,7 @@ mkRdrFunBindEC :: Arity
                -> [LMatch GhcPs (LHsExpr GhcPs)]
                -> LHsBind GhcPs
 mkRdrFunBindEC arity catch_all
-                 fun@(L loc _fun_rdr) matches = L loc (mkFunBind fun matches')
+                 fun@(L loc _fun_rdr) matches = L loc (mkFunBind Generated fun matches')
  where
    -- Catch-all eqn looks like
    --     fmap _ z = case z of {}
@@ -2071,7 +2071,7 @@ mkRdrFunBindEC arity catch_all
 mkRdrFunBindSE :: Arity -> Located RdrName ->
                     [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
 mkRdrFunBindSE arity
-                 fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
+                 fun@(L loc fun_rdr) matches = L loc (mkFunBind Generated fun matches')
  where
    -- Catch-all eqn looks like
    --     compare _ _ = error "Void compare"
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 945e496db7..c2803571cf 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -431,6 +431,39 @@ When a variable is used, we compare
 
 -}
 
+-- | We only want to produce warnings for TH-splices if the user requests so.
+-- See Note [Warnings for TH splices].
+getThSpliceOrigin :: TcM Origin
+getThSpliceOrigin = do
+  warn <- goptM Opt_EnableThSpliceWarnings
+  if warn then return FromSource else return Generated
+
+{- Note [Warnings for TH splices]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We only produce warnings for TH splices when the user requests so
+(-fenable-th-splice-warnings). There are multiple reasons:
+
+  * It's not clear that the user that compiles a splice is the author of the code
+    that produces the warning. Think of the situation where she just splices in
+    code from a third-party library that produces incomplete pattern matches.
+    In this scenario, the user isn't even able to fix that warning.
+  * Gathering information for producing the warnings (pattern-match check
+    warnings in particular) is costly. There's no point in doing so if the user
+    is not interested in those warnings.
+
+That's why we store Origin flags in the Haskell AST. The functions from ThToHs
+take such a flag and depending on whether TH splice warnings were enabled or
+not, we pass FromSource (if the user requests warnings) or Generated
+(otherwise). This is implemented in getThSpliceOrigin.
+
+For correct pattern-match warnings it's crucial that we annotate the Origin
+consistently (#17270). In the future we could offer the Origin as part of the
+TH AST. That would enable us to give quotes from the current module get
+FromSource origin, and/or third library authors to tag certain parts of
+generated code as FromSource to enable warnings. That effort is tracked in
+#14838.
+-}
+
 {-
 ************************************************************************
 *                                                                      *
@@ -686,15 +719,16 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do
 
 runQResult
   :: (a -> String)
-  -> (SrcSpan -> a -> b)
+  -> (Origin -> SrcSpan -> a -> b)
   -> (ForeignHValue -> TcM a)
   -> SrcSpan
   -> ForeignHValue {- TH.Q a -}
   -> TcM b
 runQResult show_th f runQ expr_span hval
   = do { th_result <- runQ hval
+       ; th_origin <- getThSpliceOrigin
        ; traceTc "Got TH result:" (text (show_th th_result))
-       ; return (f expr_span th_result) }
+       ; return (f th_origin expr_span th_result) }
 
 
 -----------------
@@ -972,7 +1006,8 @@ instance TH.Quasi TcM where
 
   qAddTopDecls thds = do
       l <- getSrcSpanM
-      let either_hval = convertToHsDecls l thds
+      th_origin <- getThSpliceOrigin
+      let either_hval = convertToHsDecls th_origin l thds
       ds <- case either_hval of
               Left exn -> failWithTc $
                 hang (text "Error in a declaration passed to addTopDecls:")
@@ -1255,7 +1290,8 @@ reifyInstances th_nm th_tys
    = addErrCtxt (text "In the argument of reifyInstances:"
                  <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $
      do { loc <- getSrcSpanM
-        ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys)
+        ; th_origin <- getThSpliceOrigin
+        ; rdr_ty <- cvt th_origin loc (mkThAppTs (TH.ConT th_nm) th_tys)
           -- #9262 says to bring vars into scope, like in HsForAllTy case
           -- of rnHsTyKi
         ; let tv_rdrs = extractHsTyRdrTyVars rdr_ty
@@ -1297,10 +1333,10 @@ reifyInstances th_nm th_tys
     doc = ClassInstanceCtx
     bale_out msg = failWithTc msg
 
-    cvt :: SrcSpan -> TH.Type -> TcM (LHsType GhcPs)
-    cvt loc th_ty = case convertToHsType loc th_ty of
-                      Left msg -> failWithTc msg
-                      Right ty -> return ty
+    cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs)
+    cvt origin loc th_ty = case convertToHsType origin loc th_ty of
+      Left msg -> failWithTc msg
+      Right ty -> return ty
 
 {-
 ************************************************************************
diff --git a/docs/users_guide/8.10.1-notes.rst b/docs/users_guide/8.10.1-notes.rst
index e5ed23ca3e..4e9a9fc613 100644
--- a/docs/users_guide/8.10.1-notes.rst
+++ b/docs/users_guide/8.10.1-notes.rst
@@ -152,7 +152,7 @@ Language
   Because GHC needs to look under a type family to see that ``a`` is determined
   by the right-hand side of ``F2``\'s equation, this now needs ``-XUndecidableInstances``.
   The problem is very much akin to its need to detect some functional dependencies.
-    
+
 Compiler
 ~~~~~~~~
 
@@ -203,6 +203,9 @@ Compiler
   and much more. See the :ref:`user guide <dynflags_plugins>` for
   more details as well as an example.
 
+- Deprecated flag :ghc-flag:`-fmax-pmcheck-iterations` in favor of
+  :ghc-flag:`-fmax-pmcheck-models`, which uses a completely different mechanism.
+
 GHCi
 ~~~~
 
@@ -274,6 +277,14 @@ Template Haskell
     tStr :: String
     tStr = show MkT
 
+- TH splices by default don't generate warnings anymore. For example,
+  ``$([d| f :: Int -> void; f x = case x of {} |])`` used to generate a
+  pattern-match exhaustivity warning, which now it doesn't. The user can
+  activate warnings for TH splices with :ghc-flag:`-fenable-th-splice-warnings`.
+  The reason for opt-in is that the offending code might not have been generated
+  by code the user has control over, for example the ``singletons`` or ``lens``
+  library.
+
 ``ghc-prim`` library
 ~~~~~~~~~~~~~~~~~~~~
 
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index ec015aa673..af3d48e0a3 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -13404,6 +13404,17 @@ The syntax for a declaration splice uses "``$``" not "``splice``". The type of
 the enclosed expression must be ``Q [Dec]``, not ``[Q Dec]``. Typed expression
 splices and quotations are supported.)
 
+.. ghc-flag:: -fenable-th-splice-warnings
+    :shortdesc: Generate warnings for Template Haskell splices
+    :type: dynamic
+    :reverse: -fno-enable-th-splices
+    :category: warnings
+
+    Template Haskell splices won't be checked for warnings, because the code
+    causing the warning might originate from a third-party library and possibly
+    was not written by the user. If you want to have warnings for splices
+    anyway, pass :ghc-flag:`-fenable-th-splice-warnings`.
+
 .. _th-usage:
 
 Using Template Haskell
diff --git a/testsuite/tests/th/T17270.hs b/testsuite/tests/th/T17270.hs
new file mode 100644
index 0000000000..72f85dddd6
--- /dev/null
+++ b/testsuite/tests/th/T17270.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -Wall #-}
+module T17270 where
+
+import Data.Type.Equality
+
+f :: a :~: Int -> b :~: Bool -> a :~: b -> void
+f Refl Refl x = case x of {}
+
+$([d| g :: a :~: Int -> b :~: Bool -> a :~: b -> void
+      g Refl Refl x = case x of {}
+    |])
diff --git a/testsuite/tests/th/TH_repUnboxedTuples.stderr b/testsuite/tests/th/TH_repUnboxedTuples.stderr
index 8439b12547..3687b77a0e 100644
--- a/testsuite/tests/th/TH_repUnboxedTuples.stderr
+++ b/testsuite/tests/th/TH_repUnboxedTuples.stderr
@@ -3,11 +3,3 @@ case (# 'b', GHC.Types.False #) of
     (# 'a', GHC.Types.True #) -> (# "One", 1 #)
     (# 'b', GHC.Types.False #) -> (# "Two", 2 #)
     (# _, _ #) -> (# "Three", 3 #)
-
-TH_repUnboxedTuples.hs:18:13: warning: [-Woverlapping-patterns (in -Wdefault)]
-    Pattern match is redundant
-    In a case alternative: (# 'a', True #) -> ...
-
-TH_repUnboxedTuples.hs:18:13: warning: [-Woverlapping-patterns (in -Wdefault)]
-    Pattern match is redundant
-    In a case alternative: (# _, _ #) -> ...
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index b63b0ceb01..9e07d5035b 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -486,6 +486,8 @@ test('T16976f', normal, compile_fail, [''])
 test('T16976z', normal, compile_fail, [''])
 test('T16980', normal, compile, [''])
 test('T16980a', normal, compile_fail, [''])
+test('T17270a', extra_files(['T17270.hs']), multimod_compile, ['T17270', '-v0'])
+test('T17270b', extra_files(['T17270.hs']), multimod_compile, ['T17270', '-fenable-th-splice-warnings -v0'])
 test('T17296', normal, compile, ['-v0'])
 test('T17380', normal, compile_fail, [''])
 test('T17394', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])