X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcGenDeriv.lhs;h=4587e182c01b264c4e826f91afb087a16f6ade20;hb=2494407a750053daa61718fac371487d04818e57;hp=3bc2b6953e95cfeb09f888d39fc905c8fac3b982;hpb=7a3bd641457666e10d0a47be9f22762e03defbf0;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 3bc2b69..4587e18 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -31,9 +31,9 @@ IMP_Ubiq() IMPORT_1_3(List(partition)) import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..), - GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qualifier(..), Stmt, - ArithSeqInfo, Sig, HsType, FixityDecl, Fake ) -import RdrHsSyn ( RdrName(..), varQual, varUnqual, + GRHS(..), HsExpr(..), HsLit(..), InPat(..), Stmt(..), DoOrListComp(..), + ArithSeqInfo, Sig, HsType, FixityDecl, Fixity, Fake ) +import RdrHsSyn ( RdrName(..), varQual, varUnqual, mkOpApp, SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat) ) -- import RnHsSyn ( RenamedFixityDecl(..) ) @@ -42,7 +42,7 @@ import Id ( GenId, dataConNumFields, isNullaryDataCon, dataConTag, dataConRawArgTys, fIRST_TAG, isDataCon, SYN_IE(DataCon), SYN_IE(ConTag) ) import Maybes ( maybeToBool ) -import Name ( getOccString, getSrcLoc, occNameString, modAndOcc, OccName, Name ) +import Name ( getOccString, getOccName, getSrcLoc, occNameString, modAndOcc, OccName, Name ) import PrimOp ( PrimOp(..) ) import PrelInfo -- Lots of RdrNames @@ -175,7 +175,7 @@ gen_Eq_binds tycon where nested_eq_expr [] [] [] = true_Expr nested_eq_expr tys as bs - = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs) + = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs) where nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b)) \end{code} @@ -304,7 +304,8 @@ gen_Ord_binds tycon = partition isNullaryDataCon (tyConDataCons tycon) cmp_eq - = mk_FunMonoBind tycon_loc cmp_eq_RDR (map pats_etc nonnullary_cons ++ deflt_pats_etc) + = mk_FunMonoBind tycon_loc cmp_eq_RDR (map pats_etc nonnullary_cons ++ + [([WildPatIn, WildPatIn], default_rhs)]) where pats_etc data_con = ([con1_pat, con2_pat], @@ -326,10 +327,10 @@ gen_Ord_binds tycon = let eq_expr = nested_compare_expr tys as bs in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b) - deflt_pats_etc - = if null nullary_cons - then [] - else [([a_Pat, b_Pat], eqTag_Expr)] + 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 -------------------------------------------------------------------- defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_] @@ -365,6 +366,8 @@ we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a \begin{verbatim} instance ... Enum (Foo ...) where + toEnum i = tag2con_Foo i + enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo] -- or, really... @@ -389,11 +392,17 @@ For @enumFromTo@ and @enumFromThenTo@, we use the default methods. gen_Enum_binds :: TyCon -> RdrNameMonoBinds gen_Enum_binds tycon - = enum_from `AndMonoBinds` + = to_enum `AndMonoBinds` + enum_from `AndMonoBinds` enum_from_then `AndMonoBinds` from_enum where tycon_loc = getSrcLoc tycon + + to_enum + = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $ + mk_easy_App (tag2con_RDR tycon) [a_RDR] + enum_from = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ @@ -553,7 +562,7 @@ gen_Ix_binds tycon grhs = [OtherwiseGRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc] in HsCase - (HsPar (OpApp (HsVar dh_RDR) (HsVar minusH_RDR) (HsVar ah_RDR))) + (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR)) [PatMatch (VarPatIn c_RDR) (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))] tycon_loc @@ -568,8 +577,8 @@ gen_Ix_binds tycon untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(b_RDR, bh_RDR)] ( untag_Expr tycon [(c_RDR, ch_RDR)] ( - HsIf (HsPar (OpApp (HsVar ch_RDR) (HsVar geH_RDR) (HsVar ah_RDR))) ( - (OpApp (HsVar ch_RDR) (HsVar leH_RDR) (HsVar bh_RDR)) + HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) ( + (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR)) ) {-else-} ( false_Expr ) tycon_loc)))) @@ -597,12 +606,16 @@ gen_Ix_binds tycon -------------------------------------------------------------- single_con_range - = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] ( - ListComp (con_expr cs_needed) (zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed) - ) + = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] $ + HsDo ListComp stmts tycon_loc where - mk_qual a b c = GeneratorQual (VarPatIn c) - (HsApp (HsVar range_RDR) (ExplicitTuple [HsVar a, HsVar b])) + stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed + ++ + [ReturnStmt (con_expr cs_needed)] + + mk_qual a b c = BindStmt (VarPatIn c) + (HsApp (HsVar range_RDR) (ExplicitTuple [HsVar a, HsVar b])) + tycon_loc ---------------- single_con_index @@ -610,19 +623,19 @@ gen_Ix_binds tycon foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed)) where mk_index multiply_by (l, u, i) - =OpApp ( + = genOpApp ( (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i)) - ) (HsVar plus_RDR) ( - OpApp ( + ) plus_RDR ( + genOpApp ( (HsApp (HsVar rangeSize_RDR) (ExplicitTuple [HsVar l, HsVar u])) - ) (HsVar times_RDR) multiply_by + ) times_RDR multiply_by ) range_size = mk_easy_FunMonoBind tycon_loc rangeSize_RDR [TuplePatIn [a_Pat, b_Pat]] [] ( - OpApp ( + genOpApp ( (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [a_Expr, b_Expr])) b_Expr) - ) (HsVar plus_RDR) (HsLit (HsInt 1))) + ) plus_RDR (HsLit (HsInt 1))) ------------------ single_con_inRange @@ -659,7 +672,7 @@ gen_Read_binds tycon = map read_con (tyConDataCons tycon) in mk_easy_FunMonoBind tycon_loc readsPrec_RDR [a_Pat, b_Pat] [] ( - foldl1 append_Expr read_con_comprehensions + foldr1 append_Expr read_con_comprehensions ) where read_con data_con -- note: "b" is the string being "read" @@ -673,31 +686,38 @@ gen_Read_binds tycon nullary_con = isNullaryDataCon data_con con_qual - = GeneratorQual + = BindStmt (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat]) (HsApp (HsVar lex_RDR) c_Expr) + tycon_loc field_quals = snd (mapAccumL mk_qual d_Expr (zipEqual "as_needed" as_needed bs_needed)) + mk_qual draw_from (con_field, str_left) + = (HsVar str_left, -- what to draw from down the line... + BindStmt + (TuplePatIn [VarPatIn con_field, VarPatIn str_left]) + (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from) + tycon_loc + ) + + result_expr = ExplicitTuple [con_expr, if null bs_needed + then d_Expr + else HsVar (last bs_needed)] + + stmts = (con_qual : field_quals) ++ [ReturnStmt result_expr] + read_paren_arg = if nullary_con then -- must be False (parens are surely optional) false_Expr else -- parens depend on precedence... - HsPar (OpApp a_Expr (HsVar gt_RDR) (HsLit (HsInt 9))) + HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt 9))) in HsApp ( readParen_Expr read_paren_arg $ HsPar $ - HsLam (mk_easy_Match tycon_loc [c_Pat] [] ( - ListComp (ExplicitTuple [con_expr, - if null bs_needed then d_Expr else HsVar (last bs_needed)]) - (con_qual : field_quals))) + HsLam (mk_easy_Match tycon_loc [c_Pat] [] $ + HsDo ListComp stmts tycon_loc) ) (HsVar b_RDR) - where - mk_qual draw_from (con_field, str_left) - = (HsVar str_left, -- what to draw from down the line... - GeneratorQual - (TuplePatIn [VarPatIn con_field, VarPatIn str_left]) - (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from)) \end{code} %************************************************************************ @@ -747,7 +767,7 @@ gen_Show_binds tycon ([a_Pat, con_pat], show_con) else ([a_Pat, con_pat], - showParen_Expr (HsPar (OpApp a_Expr (HsVar ge_RDR) (HsLit (HsInt 10)))) + showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt 10)))) (HsPar (nested_compose_Expr show_thingies))) where spacified [] = [] @@ -795,7 +815,8 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) var_RDR = qual_orig_name var gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con) - = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon)) + = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon) ++ + [([WildPatIn], impossible_Expr)]) where mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr) @@ -812,6 +833,7 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag) where max_tag = case (tyConDataCons tycon) of data_cons -> toInteger ((length data_cons) - fIRST_TAG) + \end{code} %************************************************************************ @@ -912,9 +934,9 @@ careful_compare_Case ty lt eq gt a b compare_gen_Case compare_RDR lt eq gt a b else -- we have to do something special for primitive things... - HsIf (HsPar (OpApp a (HsVar relevant_eq_op) b)) + HsIf (genOpApp a relevant_eq_op b) eq - (HsIf (HsPar (OpApp a (HsVar relevant_lt_op) b)) lt gt mkGeneratedSrcLoc) + (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc) mkGeneratedSrcLoc where relevant_eq_op = assoc_ty_id eq_op_tbl ty @@ -948,17 +970,17 @@ lt_op_tbl = and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -and_Expr a b = OpApp a (HsVar and_RDR) b -append_Expr a b = OpApp a (HsVar append_RDR) b +and_Expr a b = genOpApp a and_RDR b +append_Expr a b = genOpApp a append_RDR b ----------------------------------------------------------------------- eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr eq_Expr ty a b = if not (isPrimType ty) then - OpApp a (HsVar eq_RDR) b + genOpApp a eq_RDR b else -- we have to do something special for primitive things... - OpApp a (HsVar relevant_eq_op) b + genOpApp a relevant_eq_op b where relevant_eq_op = assoc_ty_id eq_op_tbl ty \end{code} @@ -981,7 +1003,7 @@ cmp_tags_Expr :: RdrName -- Comparison op -> RdrNameHsExpr cmp_tags_Expr op a b true_case false_case - = HsIf (HsPar (OpApp (HsVar a) (HsVar op) (HsVar b))) true_case false_case mkGeneratedSrcLoc + = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc enum_from_to_Expr :: RdrNameHsExpr -> RdrNameHsExpr @@ -1006,8 +1028,19 @@ nested_compose_Expr [e] = parenify e nested_compose_Expr (e:es) = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es) +-- impossible_Expr is used in case RHSs that should never happen. +-- We generate these to keep the desugarer from complaining that they *might* happen! +impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv"))) + parenify e@(HsVar _) = e parenify e = HsPar e + +-- genOpApp wraps brackets round the operator application, so that the +-- renamer won't subsequently try to re-associate it. +-- For some reason the renamer doesn't reassociate it right, and I can't +-- be bothered to find out why just now. + +genOpApp e1 op e2 = mkOpApp e1 op e2 \end{code} \begin{code} @@ -1047,21 +1080,7 @@ d_Pat = VarPatIn d_RDR con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName -con2tag_RDR tycon - = let (mod, nm) = modAndOcc tycon - con2tag = SLIT("con2tag_") _APPEND_ occNameString nm _APPEND_ SLIT("#") - in - varQual (mod, con2tag) - -tag2con_RDR tycon - = let (mod, nm) = modAndOcc tycon - tag2con = SLIT("tag2con_") _APPEND_ occNameString nm _APPEND_ SLIT("#") - in - varQual (mod, tag2con) - -maxtag_RDR tycon - = let (mod, nm) = modAndOcc tycon - maxtag = SLIT("maxtag_") _APPEND_ occNameString nm _APPEND_ SLIT("#") - in - varQual (mod, maxtag) +con2tag_RDR tycon = varUnqual (SLIT("con2tag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#")) +tag2con_RDR tycon = varUnqual (SLIT("tag2con_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#")) +maxtag_RDR tycon = varUnqual (SLIT("maxtag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#")) \end{code}