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( ...@@ -48,7 +48,7 @@ module GHC.Hs.Utils(
mkChunkified, chunkify, mkChunkified, chunkify,
-- * Bindings -- * Bindings
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind, mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind,
mkPatSynBind, mkPatSynBind,
isInfixFunBind, isInfixFunBind,
...@@ -800,11 +800,12 @@ l ...@@ -800,11 +800,12 @@ l
************************************************************************ ************************************************************************
-} -}
mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] mkFunBind :: Origin -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs -> HsBind GhcPs
-- ^ Not infix, with place holders for coercion and free vars -- ^ Not infix, with place holders for coercion and free vars
mkFunBind fn ms = FunBind { fun_id = fn mkFunBind origin fn ms
, fun_matches = mkMatchGroup Generated ms = FunBind { fun_id = fn
, fun_matches = mkMatchGroup origin ms
, fun_co_fn = idHsWrapper , fun_co_fn = idHsWrapper
, fun_ext = noExtField , fun_ext = noExtField
, fun_tick = [] } , fun_tick = [] }
...@@ -820,7 +821,7 @@ mkTopFunBind origin fn ms = FunBind { fun_id = fn ...@@ -820,7 +821,7 @@ mkTopFunBind origin fn ms = FunBind { fun_id = fn
, fun_tick = [] } , fun_tick = [] }
mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs 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 :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind var rhs = cL (getLoc rhs) $ mkVarBind var rhs = cL (getLoc rhs) $
...@@ -846,10 +847,12 @@ isInfixFunBind _ = False ...@@ -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 -> LHsExpr GhcPs -> LHsBind GhcPs
mk_easy_FunBind loc fun pats expr mkSimpleGeneratedFunBind loc fun pats expr
= cL loc $ mkFunBind (cL loc fun) = cL loc $ mkFunBind Generated (cL loc fun)
[mkMatch (mkPrefixFunRhs (cL loc fun)) pats expr [mkMatch (mkPrefixFunRhs (cL loc fun)) pats expr
(noLoc emptyLocalBinds)] (noLoc emptyLocalBinds)]
......
...@@ -58,27 +58,28 @@ import System.IO.Unsafe ...@@ -58,27 +58,28 @@ import System.IO.Unsafe
------------------------------------------------------------------- -------------------------------------------------------------------
-- The external interface -- The external interface
convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs] convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]
convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds)) convertToHsDecls origin loc ds = initCvt origin loc (fmap catMaybes (mapM cvt_dec ds))
where where
cvt_dec d = wrapMsg "declaration" d (cvtDec d) cvt_dec d = wrapMsg "declaration" d (cvtDec d)
convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs) convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)
convertToHsExpr loc e convertToHsExpr origin loc e
= initCvt loc $ wrapMsg "expression" e $ cvtl e = initCvt origin loc $ wrapMsg "expression" e $ cvtl e
convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs) convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)
convertToPat loc p convertToPat origin loc p
= initCvt loc $ wrapMsg "pattern" p $ cvtPat p = initCvt origin loc $ wrapMsg "pattern" p $ cvtPat p
convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs) convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)
convertToHsType loc t convertToHsType origin loc t
= initCvt loc $ wrapMsg "type" t $ cvtType 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) 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 -- Can fail, with a single error message
-- NB: If the conversion succeeds with (Right x), there should -- NB: If the conversion succeeds with (Right x), there should
...@@ -91,45 +92,48 @@ newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) } ...@@ -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 -- the spliced-in declarations get a location that at least relates to the splice point
instance Applicative CvtM where instance Applicative CvtM where
pure x = CvtM $ \loc -> Right (loc,x) pure x = CvtM $ \_ loc -> Right (loc,x)
(<*>) = ap (<*>) = ap
instance Monad CvtM where instance Monad CvtM where
(CvtM m) >>= k = CvtM $ \loc -> case m loc of (CvtM m) >>= k = CvtM $ \origin loc -> case m origin loc of
Left err -> Left err Left err -> Left err
Right (loc',v) -> unCvtM (k v) loc' Right (loc',v) -> unCvtM (k v) origin loc'
initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a initCvt :: Origin -> SrcSpan -> CvtM a -> Either MsgDoc a
initCvt loc (CvtM m) = fmap snd (m loc) initCvt origin loc (CvtM m) = fmap snd (m origin loc)
force :: a -> CvtM () force :: a -> CvtM ()
force a = a `seq` return () force a = a `seq` return ()
failWith :: MsgDoc -> CvtM a 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 SrcSpan
getL = CvtM (\loc -> Right (loc,loc)) getL = CvtM (\_ loc -> Right (loc,loc))
setL :: SrcSpan -> CvtM () setL :: SrcSpan -> CvtM ()
setL loc = CvtM (\_ -> Right (loc, ())) setL loc = CvtM (\_ _ -> Right (loc, ()))
returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a 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 :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
returnJustL = fmap Just . returnL returnJustL = fmap Just . returnL
wrapParL :: HasSrcSpan a => wrapParL :: HasSrcSpan a =>
(a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess 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 wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
-- E.g wrapMsg "declaration" dec thing -- E.g wrapMsg "declaration" dec thing
wrapMsg what item (CvtM m) wrapMsg what item (CvtM m)
= CvtM (\loc -> case m loc of = CvtM $ \origin loc -> case m origin loc of
Left err -> Left (err $$ getPprStyle msg) Left err -> Left (err $$ getPprStyle msg)
Right v -> Right v) Right v -> Right v
where where
-- Show the item in pretty syntax normally, -- Show the item in pretty syntax normally,
-- but with all its constructors if you say -dppr-debug -- but with all its constructors if you say -dppr-debug
...@@ -139,9 +143,9 @@ wrapMsg what item (CvtM m) ...@@ -139,9 +143,9 @@ wrapMsg what item (CvtM m)
else text (pprint item)) else text (pprint item))
wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
wrapL (CvtM m) = CvtM (\loc -> case m loc of wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of
Left err -> Left err Left err -> Left err
Right (loc',v) -> Right (loc',cL loc v)) Right (loc',v) -> Right (loc',cL loc v)
------------------------------------------------------------------- -------------------------------------------------------------------
cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs] cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]
...@@ -152,7 +156,8 @@ cvtDec (TH.ValD pat body ds) ...@@ -152,7 +156,8 @@ cvtDec (TH.ValD pat body ds)
| TH.VarP s <- pat | TH.VarP s <- pat
= do { s' <- vNameL s = do { s' <- vNameL s
; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds) ; 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 | otherwise
= do { pat' <- cvtPat pat = do { pat' <- cvtPat pat
...@@ -172,7 +177,8 @@ cvtDec (TH.FunD nm cls) ...@@ -172,7 +177,8 @@ cvtDec (TH.FunD nm cls)
| otherwise | otherwise
= do { nm' <- vNameL nm = do { nm' <- vNameL nm
; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls ; 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) cvtDec (TH.SigD nm typ)
= do { nm' <- vNameL nm = do { nm' <- vNameL nm
...@@ -403,7 +409,8 @@ cvtDec (TH.PatSynD nm args dir pat) ...@@ -403,7 +409,8 @@ cvtDec (TH.PatSynD nm args dir pat)
cvtDir _ ImplBidir = return ImplicitBidirectional cvtDir _ ImplBidir = return ImplicitBidirectional
cvtDir n (ExplBidir cls) = cvtDir n (ExplBidir cls) =
do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) 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) cvtDec (TH.PatSynSigD nm ty)
= do { nm' <- cNameL nm = do { nm' <- cNameL nm
...@@ -464,8 +471,6 @@ cvt_ci_decs doc decs ...@@ -464,8 +471,6 @@ cvt_ci_decs doc decs
; let (binds', prob_fams') = partitionWith is_bind prob_binds' ; let (binds', prob_fams') = partitionWith is_bind prob_binds'
; let (fams', bads) = partitionWith is_fam_decl prob_fams' ; let (fams', bads) = partitionWith is_fam_decl prob_fams'
; unless (null bads) (failWith (mkBadDecMsg doc bads)) ; 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') } ; return (listToBag binds', sigs', fams', ats', adts') }
---------------- ----------------
...@@ -901,12 +906,14 @@ cvtl e = wrapL (cvt e) ...@@ -901,12 +906,14 @@ cvtl e = wrapL (cvt e)
-- lambda expressions. See #13856. -- lambda expressions. See #13856.
cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
; let pats = map (parenthesizePat appPrec) ps' ; let pats = map (parenthesizePat appPrec) ps'
; return $ HsLam noExtField (mkMatchGroup FromSource ; th_origin <- getOrigin
; return $ HsLam noExtField (mkMatchGroup th_origin
[mkSimpleMatch LambdaExpr [mkSimpleMatch LambdaExpr
pats e'])} pats e'])}
cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch CaseAlt) ms cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch CaseAlt) ms
; th_origin <- getOrigin
; return $ HsLamCase noExtField ; return $ HsLamCase noExtField
(mkMatchGroup FromSource ms') (mkMatchGroup th_origin ms')
} }
cvt (TupE es) = cvt_tup es Boxed cvt (TupE es) = cvt_tup es Boxed
cvt (UnboxedTupE es) = cvt_tup es Unboxed cvt (UnboxedTupE es) = cvt_tup es Unboxed
...@@ -923,8 +930,9 @@ cvtl e = wrapL (cvt e) ...@@ -923,8 +930,9 @@ cvtl e = wrapL (cvt e)
cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds
; e' <- cvtl e; return $ HsLet noExtField (noLoc ds') e'} ; e' <- cvtl e; return $ HsLet noExtField (noLoc ds') e'}
cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
; th_origin <- getOrigin
; return $ HsCase noExtField e' ; return $ HsCase noExtField e'
(mkMatchGroup FromSource ms') } (mkMatchGroup th_origin ms') }
cvt (DoE ss) = cvtHsDo DoExpr ss cvt (DoE ss) = cvtHsDo DoExpr ss
cvt (MDoE ss) = cvtHsDo MDoExpr ss cvt (MDoE ss) = cvtHsDo MDoExpr ss
cvt (CompE ss) = cvtHsDo ListComp ss cvt (CompE ss) = cvtHsDo ListComp ss
......
...@@ -557,6 +557,7 @@ data GeneralFlag ...@@ -557,6 +557,7 @@ data GeneralFlag
| Opt_UnboxSmallStrictFields | Opt_UnboxSmallStrictFields
| Opt_DictsCheap | Opt_DictsCheap
| Opt_EnableRewriteRules -- Apply rewrite rules during simplification | Opt_EnableRewriteRules -- Apply rewrite rules during simplification
| Opt_EnableThSpliceWarnings -- Enable warnings for TH splices
| Opt_RegsGraph -- do graph coloring register allocation | Opt_RegsGraph -- do graph coloring register allocation
| Opt_RegsIterative -- do iterative coalescing graph coloring register allocation | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation
| Opt_PedanticBottoms -- Be picky about how we treat bottom | Opt_PedanticBottoms -- Be picky about how we treat bottom
...@@ -4208,6 +4209,7 @@ fFlagsDeps = [ ...@@ -4208,6 +4209,7 @@ fFlagsDeps = [
flagSpec "eager-blackholing" Opt_EagerBlackHoling, flagSpec "eager-blackholing" Opt_EagerBlackHoling,
flagSpec "embed-manifest" Opt_EmbedManifest, flagSpec "embed-manifest" Opt_EmbedManifest,
flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules,
flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings,
flagSpec "error-spans" Opt_ErrorSpans, flagSpec "error-spans" Opt_ErrorSpans,
flagSpec "excess-precision" Opt_ExcessPrecision, flagSpec "excess-precision" Opt_ExcessPrecision,
flagSpec "expose-all-unfoldings" Opt_ExposeAllUnfoldings, flagSpec "expose-all-unfoldings" Opt_ExposeAllUnfoldings,
......
...@@ -358,11 +358,11 @@ gen_Ord_binds loc tycon = do ...@@ -358,11 +358,11 @@ gen_Ord_binds loc tycon = do
= emptyBag = emptyBag
negate_expr = nlHsApp (nlHsVar not_RDR) 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) 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 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) negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr)
get_tag con = dataConTag con - fIRST_TAG get_tag con = dataConTag con - fIRST_TAG
...@@ -381,7 +381,7 @@ gen_Ord_binds loc tycon = do ...@@ -381,7 +381,7 @@ gen_Ord_binds loc tycon = do
mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs
-- Returns a binding op a b = ... compares a and b according to op .... -- 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 dflags op)
mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs
...@@ -597,7 +597,7 @@ gen_Enum_binds loc tycon = do ...@@ -597,7 +597,7 @@ gen_Enum_binds loc tycon = do
occ_nm = getOccString tycon occ_nm = getOccString tycon
succ_enum dflags 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)] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon), nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon),
nlHsVarApps intDataCon_RDR [ah_RDR]]) nlHsVarApps intDataCon_RDR [ah_RDR]])
...@@ -607,7 +607,7 @@ gen_Enum_binds loc tycon = do ...@@ -607,7 +607,7 @@ gen_Enum_binds loc tycon = do
nlHsIntLit 1])) nlHsIntLit 1]))
pred_enum dflags 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)] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
nlHsVarApps intDataCon_RDR [ah_RDR]]) nlHsVarApps intDataCon_RDR [ah_RDR]])
...@@ -619,7 +619,7 @@ gen_Enum_binds loc tycon = do ...@@ -619,7 +619,7 @@ gen_Enum_binds loc tycon = do
(mkIntegralLit (-1 :: Int)))])) (mkIntegralLit (-1 :: Int)))]))
to_enum dflags to_enum dflags
= mk_easy_FunBind loc toEnum_RDR [a_Pat] $ = mkSimpleGeneratedFunBind loc toEnum_RDR [a_Pat] $
nlHsIf (nlHsApps and_RDR nlHsIf (nlHsApps and_RDR
[nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
nlHsApps le_RDR [ nlHsVar a_RDR nlHsApps le_RDR [ nlHsVar a_RDR
...@@ -628,7 +628,7 @@ gen_Enum_binds loc tycon = do ...@@ -628,7 +628,7 @@ gen_Enum_binds loc tycon = do
(illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon)) (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon))
enum_from dflags 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)] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
nlHsApps map_RDR nlHsApps map_RDR
[nlHsVar (tag2con_RDR dflags tycon), [nlHsVar (tag2con_RDR dflags tycon),
...@@ -637,7 +637,7 @@ gen_Enum_binds loc tycon = do ...@@ -637,7 +637,7 @@ gen_Enum_binds loc tycon = do
(nlHsVar (maxtag_RDR dflags tycon)))] (nlHsVar (maxtag_RDR dflags tycon)))]
enum_from_then dflags 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)] $ untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
nlHsPar (enum_from_then_to_Expr nlHsPar (enum_from_then_to_Expr
...@@ -650,7 +650,7 @@ gen_Enum_binds loc tycon = do ...@@ -650,7 +650,7 @@ gen_Enum_binds loc tycon = do
)) ))
from_enum dflags 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)] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
(nlHsVarApps intDataCon_RDR [ah_RDR]) (nlHsVarApps intDataCon_RDR [ah_RDR])
...@@ -766,7 +766,7 @@ gen_Ix_binds loc tycon = do ...@@ -766,7 +766,7 @@ gen_Ix_binds loc tycon = do
] ]
enum_range dflags 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 [(a_RDR, ah_RDR)] $
untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
...@@ -775,7 +775,7 @@ gen_Ix_binds loc tycon = do ...@@ -775,7 +775,7 @@ gen_Ix_binds loc tycon = do
(nlHsVarApps intDataCon_RDR [bh_RDR])) (nlHsVarApps intDataCon_RDR [bh_RDR]))
enum_index dflags enum_index dflags
= mk_easy_FunBind loc unsafeIndex_RDR = mkSimpleGeneratedFunBind loc unsafeIndex_RDR
[noLoc (AsPat noExtField (noLoc c_RDR) [noLoc (AsPat noExtField (noLoc c_RDR)
(nlTuplePat [a_Pat, nlWildPat] Boxed)), (nlTuplePat [a_Pat, nlWildPat] Boxed)),
d_Pat] ( d_Pat] (
...@@ -792,7 +792,7 @@ gen_Ix_binds loc tycon = do ...@@ -792,7 +792,7 @@ gen_Ix_binds loc tycon = do
-- This produces something like `(ch >= ah) && (ch <= bh)` -- This produces something like `(ch >= ah) && (ch <= bh)`
enum_inRange dflags 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 [(a_RDR, ah_RDR)] (
untag_Expr dflags tycon [(b_RDR, bh_RDR)] ( untag_Expr dflags tycon [(b_RDR, bh_RDR)] (
untag_Expr dflags tycon [(c_RDR, ch_RDR)] ( untag_Expr dflags tycon [(c_RDR, ch_RDR)] (
...@@ -825,7 +825,7 @@ gen_Ix_binds loc tycon = do ...@@ -825,7 +825,7 @@ gen_Ix_binds loc tycon = do
-------------------------------------------------------------- --------------------------------------------------------------
single_con_range single_con_range
= mk_easy_FunBind loc range_RDR = mkSimpleGeneratedFunBind loc range_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
noLoc (mkHsComp ListComp stmts con_expr) noLoc (mkHsComp ListComp stmts con_expr)
where where
...@@ -837,7 +837,7 @@ gen_Ix_binds loc tycon = do ...@@ -837,7 +837,7 @@ gen_Ix_binds loc tycon = do
---------------- ----------------
single_con_index single_con_index
= mk_easy_FunBind loc unsafeIndex_RDR = mkSimpleGeneratedFunBind loc unsafeIndex_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
con_pat cs_needed] con_pat cs_needed]
-- We need to reverse the order we consider the components in -- We need to reverse the order we consider the components in
...@@ -863,7 +863,7 @@ gen_Ix_binds loc tycon = do ...@@ -863,7 +863,7 @@ gen_Ix_binds loc tycon = do
------------------ ------------------
single_con_inRange single_con_inRange
= mk_easy_FunBind loc inRange_RDR = mkSimpleGeneratedFunBind loc inRange_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
con_pat cs_needed] $ con_pat cs_needed] $
if con_arity == 0 if con_arity == 0
...@@ -1380,7 +1380,7 @@ gen_data dflags data_type_name constr_names loc rep_tc ...@@ -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)) mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
------------ gunfold ------------ gunfold
gunfold_bind = mk_easy_FunBind loc gunfold_bind = mkSimpleGeneratedFunBind loc
gunfold_RDR gunfold_RDR
[k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat] [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat]
gunfold_rhs gunfold_rhs
...@@ -1409,7 +1409,7 @@ gen_data dflags data_type_name constr_names loc rep_tc ...@@ -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) to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)
------------ dataTypeOf ------------ dataTypeOf
dataTypeOf_bind = mk_easy_FunBind dataTypeOf_bind = mkSimpleGeneratedFunBind
loc loc
dataTypeOf_RDR dataTypeOf_RDR
[nlWildPat] [nlWildPat]
...@@ -1436,7 +1436,7 @@ gen_data dflags data_type_name constr_names loc rep_tc ...@@ -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 | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
| otherwise = emptyBag | otherwise = emptyBag
mk_gcast dataCast_RDR gcast_RDR 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)) (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
...@@ -2019,7 +2019,7 @@ mkFunBindSE arity loc fun pats_and_exprs ...@@ -2019,7 +2019,7 @@ mkFunBindSE arity loc fun pats_and_exprs
mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs -> LHsBind GhcPs
mkRdrFunBind fun@(L loc _fun_rdr) matches 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 -- | 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 -- with the given arity that uses an empty case expression for the last
...@@ -2047,7 +2047,7 @@ mkRdrFunBindEC :: Arity ...@@ -2047,7 +2047,7 @@ mkRdrFunBindEC :: Arity