summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSebastian Graf <sebastian.graf@kit.edu>2019-11-25 15:51:40 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2019-11-27 00:14:59 -0500
commit5a08f7d405bbedfdc20c07f64726899f594e9d07 (patch)
treeaea542ece13a9c6f8a301f6d9de01e37f395f69e
parent8b8dc36653878de5556e368bd3e93abf66f839e9 (diff)
downloadhaskell-5a08f7d405bbedfdc20c07f64726899f594e9d07.tar.gz
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.
-rw-r--r--compiler/GHC/Hs/Utils.hs25
-rw-r--r--compiler/GHC/ThToHs.hs84
-rw-r--r--compiler/main/DynFlags.hs2
-rw-r--r--compiler/typecheck/TcGenDeriv.hs44
-rw-r--r--compiler/typecheck/TcSplice.hs52
-rw-r--r--docs/users_guide/8.10.1-notes.rst13
-rw-r--r--docs/users_guide/glasgow_exts.rst11
-rw-r--r--testsuite/tests/th/T17270.hs15
-rw-r--r--testsuite/tests/th/TH_repUnboxedTuples.stderr8
-rw-r--r--testsuite/tests/th/all.T2
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'])