summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-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
5 files changed, 128 insertions, 79 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
{-
************************************************************************
View Lorry Controller Status