Make warnings for TH splices opt-in

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.

1 files changed, 14 insertions, 11 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)]