Commit 5a08f7d4 authored by Sebastian Graf's avatar Sebastian Graf Committed by Marge Bot

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.
parent 8b8dc366
Pipeline #13229 passed with stages
in 477 minutes and 8 seconds
......@@ -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)]
......
......@@ -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
......
......@@ -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,
......
......@@ -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"
......
......@@ -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
{-
************************************************************************
......
......@@ -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
~~~~~~~~~~~~~~~~~~~~
......
......@@ -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
......
{-# 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 {}
|])
......@@ -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: (# _, _ #) -> ...
......@@ -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'])
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment