diff options
Diffstat (limited to 'compiler/typecheck/TcGenDeriv.hs')
| -rw-r--r-- | compiler/typecheck/TcGenDeriv.hs | 313 |
1 files changed, 222 insertions, 91 deletions
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index 7e79c12ed6..1debdddd7d 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -37,6 +37,8 @@ module TcGenDeriv ( #include "HsVersions.h" +import GhcPrelude + import TcRnMonad import HsSyn import RdrName @@ -124,7 +126,7 @@ possibly zero of them). Here's an example, with both \tr{N}ullary and case (a1 `eqFloat#` a2) of r -> r for that particular test. -* If there are a lot of (more than en) nullary constructors, we emit a +* If there are a lot of (more than ten) nullary constructors, we emit a catch-all clause of the form: (==) a b = case (con2tag_Foo a) of { a# -> @@ -192,8 +194,9 @@ gen_Eq_binds loc tycon = do | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon method_binds dflags = unitBag (eq_bind dflags) - eq_bind dflags = mkFunBindSE 2 loc eq_RDR (map pats_etc pat_match_cons - ++ fall_through_eqn dflags) + eq_bind dflags = mkFunBindEC 2 loc eq_RDR (const true_Expr) + (map pats_etc pat_match_cons + ++ fall_through_eqn dflags) ------------------------------------------------------------------ pats_etc data_con @@ -211,7 +214,9 @@ gen_Eq_binds loc tycon = do where nested_eq_expr [] [] [] = true_Expr nested_eq_expr tys as bs - = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs) + = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs) + -- Using 'foldr1' here ensures that the derived code is correctly + -- associated. See Trac #10859. where nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b)) @@ -337,7 +342,7 @@ gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff) gen_Ord_binds loc tycon = do dflags <- getDynFlags return $ if null tycon_data_cons -- No data-cons => invoke bale-out case - then ( unitBag $ mkFunBindSE 2 loc compare_RDR [] + then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) [] , emptyBag) else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags , aux_binds) @@ -444,7 +449,7 @@ gen_Ord_binds loc tycon = do , mkHsCaseAlt nlWildPat (gtResult op) ] where tag = get_tag data_con - tag_lit = noLoc (HsLit (HsIntPrim NoSourceText (toInteger tag))) + tag_lit = noLoc (HsLit noExt (HsIntPrim NoSourceText (toInteger tag))) mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs) -- First argument 'a' known to be built with K @@ -458,7 +463,7 @@ gen_Ord_binds loc tycon = do mkTagCmp :: DynFlags -> OrdOp -> LHsExpr GhcPs -- Both constructors known to be nullary - -- genreates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b# + -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b# mkTagCmp dflags op = untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $ unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR @@ -611,7 +616,8 @@ gen_Enum_binds loc tycon = do (nlHsApp (nlHsVar (tag2con_RDR dflags tycon)) (nlHsApps plus_RDR [ nlHsVarApps intDataCon_RDR [ah_RDR] - , nlHsLit (HsInt def (mkIntegralLit (-1 :: Int)))])) + , nlHsLit (HsInt noExt + (mkIntegralLit (-1 :: Int)))])) to_enum dflags = mk_easy_FunBind loc toEnum_RDR [a_Pat] $ @@ -771,7 +777,7 @@ gen_Ix_binds loc tycon = do enum_index dflags = mk_easy_FunBind loc unsafeIndex_RDR - [noLoc (AsPat (noLoc c_RDR) + [noLoc (AsPat noExt (noLoc c_RDR) (nlTuplePat [a_Pat, nlWildPat] Boxed)), d_Pat] ( untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( @@ -898,9 +904,7 @@ instance Read T where -- Record construction binds even more tightly than application do expectP (Ident "T1") expectP (Punc '{') - expectP (Ident "f1") - expectP (Punc '=') - x <- ReadP.reset Read.readPrec + x <- Read.readField "f1" (ReadP.reset readPrec) expectP (Punc '}') return (T1 { f1 = x })) +++ @@ -961,11 +965,15 @@ gen_Read_binds get_fixity loc tycon data_cons = tyConDataCons tycon (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons - read_prec = mkHsVarBind loc readPrec_RDR - (nlHsApp (nlHsVar parens_RDR) read_cons) + read_prec = mkHsVarBind loc readPrec_RDR rhs + where + rhs | null data_cons -- See Note [Read for empty data types] + = nlHsVar pfail_RDR + | otherwise + = nlHsApp (nlHsVar parens_RDR) + (foldr1 mk_alt (read_nullary_cons ++ + read_non_nullary_cons)) - read_cons | null data_cons = nlHsVar pfail_RDR -- See Note [Read for empty data types] - | otherwise = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons) read_non_nullary_cons = map read_non_nullary_con non_nullary_cons read_nullary_cons @@ -1066,21 +1074,32 @@ gen_Read_binds get_fixity loc tycon read_arg a ty = ASSERT( not (isUnliftedType ty) ) noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])) - read_field lbl a = read_lbl lbl ++ - [read_punc "=", - noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))] - - -- When reading field labels we might encounter - -- a = 3 - -- _a = 3 - -- or (#) = 4 - -- Note the parens! - read_lbl lbl | isSym lbl_str - = [read_punc "(", symbol_pat lbl_str, read_punc ")"] - | otherwise - = ident_h_pat lbl_str - where - lbl_str = unpackFS lbl + -- When reading field labels we might encounter + -- a = 3 + -- _a = 3 + -- or (#) = 4 + -- Note the parens! + read_field lbl a = + [noLoc + (mkBindStmt + (nlVarPat a) + (nlHsApp + read_field + (nlHsVarApps reset_RDR [readPrec_RDR]) + ) + ) + ] + where + lbl_str = unpackFS lbl + mk_read_field read_field_rdr lbl + = nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)] + read_field + | isSym lbl_str + = mk_read_field readSymField_RDR lbl_str + | Just (ss, '#') <- snocView lbl_str -- #14918 + = mk_read_field readFieldHash_RDR ss + | otherwise + = mk_read_field readField_RDR lbl_str {- ************************************************************************ @@ -1120,7 +1139,7 @@ gen_Show_binds get_fixity loc tycon = (unitBag shows_prec, emptyBag) where data_cons = tyConDataCons tycon - shows_prec = mkFunBindSE 1 loc showsPrec_RDR (map pats_etc data_cons) + shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons) comma_space = nlHsVar showCommaSpace_RDR pats_etc data_con @@ -1130,7 +1149,7 @@ gen_Show_binds get_fixity loc tycon | otherwise = ([a_Pat, con_pat], showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit - (HsInt def (mkIntegralLit con_prec_plus_one)))) + (HsInt noExt (mkIntegralLit con_prec_plus_one)))) (nlHsPar (nested_compose_Expr show_thingies))) where data_con_RDR = getRdrName data_con @@ -1214,7 +1233,7 @@ mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString st -- | showsPrec :: Show a => Int -> a -> ShowS mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs mk_showsPrec_app p x - = nlHsApps showsPrec_RDR [nlHsLit (HsInt def (mkIntegralLit p)), x] + = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExt (mkIntegralLit p)), x] -- | shows :: Show a => a -> ShowS mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs @@ -1311,7 +1330,7 @@ gen_data dflags data_type_name constr_names loc rep_tc genDataTyCon :: DerivStuff genDataTyCon -- $dT = DerivHsBind (mkHsVarBind loc data_type_name rhs, - L loc (TypeSig [L loc data_type_name] sig_ty)) + L loc (TypeSig noExt [L loc data_type_name] sig_ty)) sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR) rhs = nlHsVar mkDataType_RDR @@ -1321,7 +1340,7 @@ gen_data dflags data_type_name constr_names loc rep_tc genDataDataCon :: DataCon -> RdrName -> DerivStuff genDataDataCon dc constr_name -- $cT1 etc = DerivHsBind (mkHsVarBind loc constr_name rhs, - L loc (TypeSig [L loc constr_name] sig_ty)) + L loc (TypeSig noExt [L loc constr_name] sig_ty)) where sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR) rhs = nlHsApps mkConstr_RDR constr_args @@ -1341,11 +1360,11 @@ gen_data dflags data_type_name constr_names loc rep_tc | otherwise = prefix_RDR ------------ gfoldl - gfoldl_bind = mkFunBindSE 3 loc gfoldl_RDR (map gfoldl_eqn data_cons) + gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons) gfoldl_eqn con = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed], - foldl mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed) + foldl' mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed) where con_name :: RdrName con_name = getRdrName con @@ -1377,7 +1396,7 @@ gen_data dflags data_type_name constr_names loc rep_tc tag = dataConTag dc ------------ toConstr - toCon_bind = mkFunBindSE 1 loc toConstr_RDR + toCon_bind = mkFunBindEC 1 loc toConstr_RDR id (zipWith to_con_eqn data_cons constr_names) to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name) @@ -1512,23 +1531,11 @@ makeG_d. -} gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) -gen_Lift_binds loc tycon - | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR) - [mkMatch (mkPrefixFunRhs (L loc lift_RDR)) - [nlWildPat] errorMsg_Expr - (noLoc emptyLocalBinds)]) - , emptyBag) - | otherwise = (unitBag lift_bind, emptyBag) +gen_Lift_binds loc tycon = (unitBag lift_bind, emptyBag) where - -- We may want to make mkFunBindSE's error message generation general - -- enough to avoid needing to duplicate its logic here. On the other - -- hand, it may not be worth the trouble. - errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit - (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str) - - lift_bind = mkFunBindSE 1 loc lift_RDR (map pats_etc data_cons) + lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr) + (map pats_etc data_cons) data_cons = tyConDataCons tycon - tycon_str = occNameString . nameOccName . tyConName $ tycon pats_etc data_con = ([con_pat], lift_Expr) @@ -1562,7 +1569,7 @@ gen_Lift_binds loc tycon lift_Expr | is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2] - | otherwise = foldl mk_appE_app conE_Expr lifted_as + | otherwise = foldl' mk_appE_app conE_Expr lifted_as (a1:a2:_) = lifted_as mk_appE_app :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs @@ -1578,39 +1585,55 @@ mk_appE_app a b = nlHsApps appE_RDR [a, b] Note [Newtype-deriving instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We take every method in the original instance and `coerce` it to fit -into the derived instance. We need a type annotation on the argument +into the derived instance. We need type applications on the argument to `coerce` to make it obvious what instantiation of the method we're coercing from. So from, say, + class C a b where - op :: a -> [b] -> Int + op :: forall c. a -> [b] -> c -> Int newtype T x = MkT <rep-ty> instance C a <rep-ty> => C a (T x) where - op = coerce @ (a -> [<rep-ty>] -> Int) - @ (a -> [T x] -> Int) - op + op = coerce @ (a -> [<rep-ty>] -> c -> Int) + @ (a -> [T x] -> c -> Int) + op :: forall c. a -> [T x] -> c -> Int + +In addition to the type applications, we also have an explicit +type signature on the entire RHS. This brings the method-bound variable +`c` into scope over the two type applications. +See Note [GND and QuantifiedConstraints] for more information on why this +is important. -Notice that we give the 'coerce' two explicitly-visible type arguments -to say how it should be instantiated. Recall +Giving 'coerce' two explicitly-visible type arguments grants us finer control +over how it should be instantiated. Recall - coerce :: Coeercible a b => a -> b + coerce :: Coercible a b => a -> b By giving it explicit type arguments we deal with the case where 'op' has a higher rank type, and so we must instantiate 'coerce' with a polytype. E.g. - class C a where op :: forall b. a -> b -> b + + class C a where op :: a -> forall b. b -> b newtype T x = MkT <rep-ty> instance C <rep-ty> => C (T x) where - op = coerce @ (forall b. <rep-ty> -> b -> b) - @ (forall b. T x -> b -> b) - op + op = coerce @ (<rep-ty> -> forall b. b -> b) + @ (T x -> forall b. b -> b) + op :: T x -> forall b. b -> b + +The use of type applications is crucial here. If we had tried using only +explicit type signatures, like so: -The type checker checks this code, and it currently requires --XImpredicativeTypes to permit that polymorphic type instantiation, -so we have to switch that flag on locally in TcDeriv.genInst. + instance C <rep-ty> => C (T x) where + op = coerce (op :: <rep-ty> -> forall b. b -> b) + :: T x -> forall b. b -> b -See #8503 for more discussion. +Then GHC will attempt to deeply skolemize the two type signatures, which will +wreak havoc with the Coercible solver. Therefore, we instead use type +applications, which do not deeply skolemize and thus avoid this issue. +The downside is that we currently require -XImpredicativeTypes to permit this +polymorphic type instantiation, so we have to switch that flag on locally in +TcDeriv.genInst. See #8503 for more discussion. Note [Newtype-deriving trickiness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1631,13 +1654,98 @@ coercing opList, thus: instance C a => C (N a) where { op = opN } opN :: (C a, D (N a)) => N a -> N a - opN = coerce @(D [a] => [a] -> [a]) - @(D (N a) => [N a] -> [N a] - opList + opN = coerce @([a] -> [a]) + @([N a] -> [N a] + opList :: D (N a) => [N a] -> [N a] But there is no reason to suppose that (D [a]) and (D (N a)) are inter-coercible; these instances might completely different. So GHC rightly rejects this code. + +Note [GND and QuantifiedConstraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example from #15290: + + class C m where + join :: m (m a) -> m a + + newtype T m a = MkT (m a) + + deriving instance + (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => + C (T m) + +The code that GHC used to generate for this was: + + instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => + C (T m) where + join = coerce @(forall a. m (m a) -> m a) + @(forall a. T m (T m a) -> T m a) + join + +This instantiates `coerce` at a polymorphic type, a form of impredicative +polymorphism, so we're already on thin ice. And in fact the ice breaks, +as we'll explain: + +The call to `coerce` gives rise to: + + Coercible (forall a. m (m a) -> m a) + (forall a. T m (T m a) -> T m a) + +And that simplified to the following implication constraint: + + forall a <no-ev>. m (T m a) ~R# m (m a) + +But because this constraint is under a `forall`, inside a type, we have to +prove it *without computing any term evidence* (hence the <no-ev>). Alas, we +*must* generate a term-level evidence binding in order to instantiate the +quantified constraint! In response, GHC currently chooses not to use such +a quantified constraint. +See Note [Instances in no-evidence implications] in TcInteract. + +But this isn't the death knell for combining QuantifiedConstraints with GND. +On the contrary, if we generate GND bindings in a slightly different way, then +we can avoid this situation altogether. Instead of applying `coerce` to two +polymorphic types, we instead let an explicit type signature do the polymorphic +instantiation, and omit the `forall`s in the type applications. +More concretely, we generate the following code instead: + + instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) => + C (T m) where + join = coerce @( m (m a) -> m a) + @(T m (T m a) -> T m a) + join :: forall a. T m (T m a) -> T m a + +Now the visible type arguments are both monotypes, so we need do any of this +funny quantified constraint instantiation business. + +You might think that that second @(T m (T m a) -> T m a) argument is redundant +in the presence of the explicit `:: forall a. T m (T m a) -> T m a` type +signature, but in fact leaving it off will break this example (from the +T15290d test case): + + class C a where + c :: Int -> forall b. b -> a + + instance C Int + + instance C Age where + c = coerce @(Int -> forall b. b -> Int) + c :: Int -> forall b. b -> Age + +That is because the explicit type signature deeply skolemizes the forall-bound +`b`, which wreaks havoc with the `Coercible` solver. An additional visible type +argument of @(Int -> forall b. b -> Age) is enough to prevent this. + +Be aware that the use of an explicit type signature doesn't /solve/ this +problem; it just makes it less likely to occur. For example, if a class has +a truly higher-rank type like so: + + class CProblem m where + op :: (forall b. ... (m b) ...) -> Int + +Then the same situation will arise again. But at least it won't arise for the +common case of methods with ordinary, prenex-quantified types. -} gen_Newtype_binds :: SrcSpan @@ -1663,13 +1771,16 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty [] rhs_expr] where Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id + (_, _, from_tau) = tcSplitSigmaTy from_ty + (_, _, to_tau) = tcSplitSigmaTy to_ty meth_RDR = getRdrName meth_id rhs_expr = nlHsVar (getRdrName coerceId) - `nlHsAppType` from_ty - `nlHsAppType` to_ty - `nlHsApp` nlHsVar meth_RDR + `nlHsAppType` from_tau + `nlHsAppType` to_tau + `nlHsApp` nlHsVar meth_RDR + `nlExprWithTySig` to_ty mk_atf_inst :: TyCon -> TcM FamInst mk_atf_inst fam_tc = do @@ -1679,7 +1790,7 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty fam_tc rep_lhs_tys rep_rhs_ty -- Check (c) from Note [GND and associated type families] in TcDeriv checkValidTyFamEqn (Just (cls, cls_tvs, lhs_env)) fam_tc rep_tvs' - rep_cvs' rep_lhs_tys rep_rhs_ty loc + rep_cvs' rep_lhs_tys rep_rhs_ty pp_lhs loc newFamInst SynFamilyInst axiom where cls_tvs = classTyVars cls @@ -1696,14 +1807,16 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs rep_tvs' = toposortTyVars rep_tvs rep_cvs' = toposortTyVars rep_cvs + pp_lhs = ppr (mkTyConApp fam_tc rep_lhs_tys) nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs -nlHsAppType e s = noLoc (e `HsAppType` hs_ty) +nlHsAppType e s = noLoc (HsAppType hs_ty e) where - hs_ty = mkHsWildCardBndrs $ nlHsParTy (typeToLHsType s) + hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s) nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs -nlExprWithTySig e s = noLoc (e `ExprWithTySig` hs_ty) +nlExprWithTySig e s = noLoc $ ExprWithTySig hs_ty + $ parenthesizeHsExpr sigPrec e where hs_ty = mkLHsSigWcType (typeToLHsType s) @@ -1753,11 +1866,11 @@ genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec -> (LHsBind GhcPs, LSig GhcPs) genAuxBindSpec dflags loc (DerivCon2Tag tycon) = (mkFunBindSE 0 loc rdr_name eqns, - L loc (TypeSig [L loc rdr_name] sig_ty)) + L loc (TypeSig noExt [L loc rdr_name] sig_ty)) where rdr_name = con2tag_RDR dflags tycon - sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $ + sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $ mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $ mkParentType tycon `mkFunTy` intPrimTy @@ -1779,20 +1892,20 @@ genAuxBindSpec dflags loc (DerivTag2Con tycon) = (mkFunBindSE 0 loc rdr_name [([nlConVarPat intDataCon_RDR [a_RDR]], nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], - L loc (TypeSig [L loc rdr_name] sig_ty)) + L loc (TypeSig noExt [L loc rdr_name] sig_ty)) where sig_ty = mkLHsSigWcType $ L loc $ - HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $ + XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $ intTy `mkFunTy` mkParentType tycon rdr_name = tag2con_RDR dflags tycon genAuxBindSpec dflags loc (DerivMaxTag tycon) = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig [L loc rdr_name] sig_ty)) + L loc (TypeSig noExt [L loc rdr_name] sig_ty)) where rdr_name = maxtag_RDR dflags tycon - sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy)) + sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy))) rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim NoSourceText max_tag)) max_tag = case (tyConDataCons tycon) of @@ -1848,7 +1961,8 @@ mkFunBindSE :: Arity -> SrcSpan -> RdrName mkFunBindSE arity loc fun pats_and_exprs = mkRdrFunBindSE arity (L loc fun) matches where - matches = [mkMatch (mkPrefixFunRhs (L loc fun)) p e + matches = [mkMatch (mkPrefixFunRhs (L loc fun)) + (map (parenthesizePat appPrec) p) e (noLoc emptyLocalBinds) | (p,e) <-pats_and_exprs] @@ -1857,6 +1971,22 @@ mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] mkRdrFunBind fun@(L loc _fun_rdr) matches = L loc (mkFunBind 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 +-- argument that is passes to the given function to produce the right-hand +-- side. +mkFunBindEC :: Arity -> SrcSpan -> RdrName + -> (LHsExpr GhcPs -> LHsExpr GhcPs) + -> [([LPat GhcPs], LHsExpr GhcPs)] + -> LHsBind GhcPs +mkFunBindEC arity loc fun catch_all pats_and_exprs + = mkRdrFunBindEC arity catch_all (L loc fun) matches + where + matches = [ mkMatch (mkPrefixFunRhs (L loc fun)) + (map (parenthesizePat appPrec) p) e + (noLoc emptyLocalBinds) + | (p,e) <- pats_and_exprs ] + -- | Produces a function binding. When no equations are given, it generates -- a binding of the given arity and an empty case expression -- for the last argument that it passes to the given function to produce @@ -2076,8 +2206,8 @@ illegal_toEnum_tag tp maxtag = (nlHsLit (mkHsString ")")))))) parenify :: LHsExpr GhcPs -> LHsExpr GhcPs -parenify e@(L _ (HsVar _)) = e -parenify e = mkHsPar e +parenify e@(L _ (HsVar _ _)) = e +parenify e = mkHsPar e -- genOpApp wraps brackets round the operator application, so that the -- renamer won't subsequently try to re-associate it. @@ -2107,7 +2237,7 @@ bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr, - true_Expr :: LHsExpr GhcPs + true_Expr, pure_Expr :: LHsExpr GhcPs a_Expr = nlHsVar a_RDR b_Expr = nlHsVar b_RDR c_Expr = nlHsVar c_RDR @@ -2117,6 +2247,7 @@ eqTag_Expr = nlHsVar eqTag_RDR gtTag_Expr = nlHsVar gtTag_RDR false_Expr = nlHsVar false_RDR true_Expr = nlHsVar true_RDR +pure_Expr = nlHsVar pure_RDR a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs a_Pat = nlVarPat a_RDR |