X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcGenDeriv.lhs;h=3fb18485670d879486a38cb1de236ebf0241e1e1;hb=e9f9ec1e57d53b9302a395ce0d02c0fa59e28341;hp=f940e169fac346489c7232d1c53561da3004c593;hpb=380e4e40e2e6b7ccb18b7103acb075d80168e595;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index f940e16..3fb1848 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -311,75 +311,80 @@ gen_Ord_binds loc tycon | Just (con, prim_tc) <- primWrapperType_maybe tycon = gen_PrimOrd_binds con prim_tc - | otherwise + | otherwise = (unitBag compare, aux_binds) - -- `AndMonoBinds` compare - -- The default declaration in PrelBase handles this + -- `AndMonoBinds` compare + -- The default declaration in PrelBase handles this where aux_binds | single_con_type = [] - | otherwise = [GenCon2Tag tycon] + | otherwise = [GenCon2Tag tycon] compare = L loc (mkFunBind (L loc compare_RDR) compare_matches) compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds] cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) []) compare_rhs - | single_con_type = cmp_eq_Expr a_Expr b_Expr - | otherwise - = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] - (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR - (cmp_eq_Expr a_Expr b_Expr) -- True case - -- False case; they aren't equal - -- So we need to do a less-than comparison on the tags - (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)) + | single_con_type = cmp_eq_Expr a_Expr b_Expr + | otherwise + = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] + (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR + (cmp_eq_Expr a_Expr b_Expr) -- True case + -- False case; they aren't equal + -- So we need to do a less-than comparison on the tags + (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR + ltTag_Expr gtTag_Expr)) tycon_data_cons = tyConDataCons tycon single_con_type = isSingleton tycon_data_cons (nullary_cons, nonnullary_cons) | isNewTyCon tycon = ([], tyConDataCons tycon) - | otherwise = partition isNullarySrcDataCon tycon_data_cons + | otherwise = partition isNullarySrcDataCon tycon_data_cons cmp_eq = mk_FunBind loc cmp_eq_RDR cmp_eq_match cmp_eq_match | isEnumerationTyCon tycon - -- We know the tags are equal, so if it's an enumeration TyCon, - -- then there is nothing left to do - -- Catch this specially to avoid warnings - -- about overlapping patterns from the desugarer, - -- and to avoid unnecessary pattern-matching + -- We know the tags are equal, so if it's an + -- enumeration TyCon, + -- then there is nothing left to do + -- Catch this specially to avoid warnings + -- about overlapping patterns from the desugarer, + -- and to avoid unnecessary pattern-matching = [([nlWildPat,nlWildPat], eqTag_Expr)] | otherwise = map pats_etc nonnullary_cons ++ - (if single_con_type then -- Omit wildcards when there's just one - [] -- constructor, to silence desugarer - else + (if single_con_type then -- Omit wildcards when there's just one + [] -- constructor, to silence desugarer + else [([nlWildPat, nlWildPat], default_rhs)]) - default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about - -- inexhaustive patterns - | otherwise = eqTag_Expr -- Some nullary constructors; - -- Tags are equal, no args => return EQ + default_rhs | null nullary_cons = -- Keep desugarer from complaining about + -- inexhaustive patterns + impossible_Expr + | otherwise = -- Some nullary constructors; + -- Tags are equal, no args => return EQ + eqTag_Expr pats_etc data_con - = ([con1_pat, con2_pat], - nested_compare_expr tys_needed as_needed bs_needed) - where - con1_pat = nlConVarPat data_con_RDR as_needed - con2_pat = nlConVarPat data_con_RDR bs_needed - - data_con_RDR = getRdrName data_con - con_arity = length tys_needed - as_needed = take con_arity as_RDRs - bs_needed = take con_arity bs_RDRs - tys_needed = dataConOrigArgTys data_con - - nested_compare_expr [ty] [a] [b] - = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b) - - nested_compare_expr (ty:tys) (a:as) (b:bs) - = let eq_expr = nested_compare_expr tys as bs - in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b) - - nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length + = ([con1_pat, con2_pat], + nested_compare_expr tys_needed as_needed bs_needed) + where + con1_pat = nlConVarPat data_con_RDR as_needed + con2_pat = nlConVarPat data_con_RDR bs_needed + + data_con_RDR = getRdrName data_con + con_arity = length tys_needed + as_needed = take con_arity as_RDRs + bs_needed = take con_arity bs_RDRs + tys_needed = dataConOrigArgTys data_con + + nested_compare_expr [ty] [a] [b] + = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b) + + nested_compare_expr (ty:tys) (a:as) (b:bs) + = let eq_expr = nested_compare_expr tys as bs + in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b) + + -- Args always equal length + nested_compare_expr _ _ _ = panic "nested_compare_expr" \end{code} Note [Comparision of primitive types] @@ -566,8 +571,8 @@ gen_Bounded_binds loc tycon data_cons = tyConDataCons tycon ----- enum-flavored: --------------------------- - min_bound_enum = mkVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) - max_bound_enum = mkVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) + min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) + max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) data_con_1 = head data_cons data_con_N = last data_cons @@ -577,9 +582,9 @@ gen_Bounded_binds loc tycon ----- single-constructor-flavored: ------------- arity = dataConSourceArity data_con_1 - min_bound_1con = mkVarBind loc minBound_RDR $ + min_bound_1con = mkHsVarBind loc minBound_RDR $ nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR) - max_bound_1con = mkVarBind loc maxBound_RDR $ + max_bound_1con = mkHsVarBind loc maxBound_RDR $ nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR) \end{code} @@ -718,7 +723,7 @@ gen_Ix_binds loc tycon mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c) (nlHsApp (nlHsVar range_RDR) - (nlTuple [nlHsVar a, nlHsVar b] Boxed)) + (mkLHsVarTuple [a,b])) ---------------- single_con_index @@ -740,11 +745,11 @@ gen_Ix_binds loc tycon ) plus_RDR ( genOpApp ( (nlHsApp (nlHsVar unsafeRangeSize_RDR) - (nlTuple [nlHsVar l, nlHsVar u] Boxed)) + (mkLHsVarTuple [l,u])) ) times_RDR (mk_index rest) ) mk_one l u i - = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i] + = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i] ------------------ single_con_inRange @@ -753,8 +758,7 @@ gen_Ix_binds loc tycon con_pat cs_needed] $ foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed) where - in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed, - nlHsVar c] + in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c] \end{code} %************************************************************************ @@ -809,16 +813,16 @@ gen_Read_binds get_fixity loc tycon where ----------------------------------------------------------------------- default_readlist - = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR) + = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR) default_readlistprec - = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) + = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) ----------------------------------------------------------------------- data_cons = tyConDataCons tycon (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons - read_prec = mkVarBind loc readPrec_RDR + read_prec = mkHsVarBind loc readPrec_RDR (nlHsApp (nlHsVar parens_RDR) read_cons) read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons) @@ -832,9 +836,8 @@ gen_Read_binds get_fixity loc tycon _ -> [nlHsApp (nlHsVar choose_RDR) (nlList (map mk_pair nullary_cons))] - mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)), - result_expr con []] - Boxed + mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)), + result_expr con []] read_non_nullary_con data_con | is_infix = mk_parser infix_prec infix_stmts body @@ -963,7 +966,7 @@ gen_Show_binds get_fixity loc tycon = (listToBag [shows_prec, show_list], []) where ----------------------------------------------------------------------- - show_list = mkVarBind loc showList_RDR + show_list = mkHsVarBind loc showList_RDR (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0)))) ----------------------------------------------------------------------- shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon)) @@ -1595,7 +1598,8 @@ genAuxBind loc (GenCon2Tag tycon) get_tag_rhs = L loc $ ExprWithTySig (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR) (nlHsApp (nlHsVar getTag_RDR) a_Expr))) - (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty)) + (noLoc (mkExplicitHsForAllTy (userHsTyVarBndrs (map noLoc tvs)) + (noLoc []) con2tag_ty)) con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs) `nlHsFunTy` @@ -1618,7 +1622,7 @@ genAuxBind loc (GenTag2Con tycon) rdr_name = tag2con_RDR tycon genAuxBind loc (GenMaxTag tycon) - = mkVarBind loc rdr_name + = mkHsVarBind loc rdr_name (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))) where rdr_name = maxtag_RDR tycon @@ -1626,16 +1630,16 @@ genAuxBind loc (GenMaxTag tycon) data_cons -> toInteger ((length data_cons) - fIRST_TAG) genAuxBind loc (MkTyCon tycon) -- $dT - = mkVarBind loc (mk_data_type_name tycon) - ( nlHsVar mkDataType_RDR + = mkHsVarBind loc (mk_data_type_name tycon) + ( nlHsVar mkDataType_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon))) `nlHsApp` nlList constrs ) where constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon] genAuxBind loc (MkDataCon dc) -- $cT1 etc - = mkVarBind loc (mk_constr_name dc) - (nlHsApps mkConstr_RDR constr_args) + = mkHsVarBind loc (mk_constr_name dc) + (nlHsApps mkConstr_RDR constr_args) where constr_args = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag