X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcGenDeriv.lhs;h=b17d29ced4f51777350131a6dde30b1fc56f3532;hb=9dd6e1c216993624a2cd74b62ca0f0569c02c26b;hp=d317f105fd6f10d0ddc081f471539e64eeb7a66e;hpb=2a74e354528a397235b42af49a99844c1712e8c4;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index d317f10..b17d29c 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -9,8 +9,6 @@ This module is nominally ``subordinate'' to @TcDeriv@, which is the This is where we do all the grimy bindings' generation. \begin{code} -#include "HsVersions.h" - module TcGenDeriv ( gen_Bounded_binds, gen_Enum_binds, @@ -27,33 +25,38 @@ module TcGenDeriv ( TagThingWanted(..) ) where -IMP_Ubiq() -IMPORT_1_3(List(partition)) +#include "HsVersions.h" -import HsSyn ( HsBinds(..), MonoBinds(..), Match(..), GRHSsAndBinds(..), - GRHS(..), HsExpr(..), HsLit(..), InPat(..), Stmt(..), DoOrListComp(..), - SYN_IE(RecFlag), recursive, - ArithSeqInfo, Sig, HsType, FixityDecl, Fixity, Fake ) +import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..), GRHS(..), + Match(..), GRHSsAndBinds(..), Stmt(..), HsLit(..), + HsBinds(..), DoOrListComp(..), + unguardedRHS + ) import RdrHsSyn ( RdrName(..), varQual, varUnqual, mkOpApp, - SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat) + RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat ) -import BasicTypes ( IfaceFlavour(..) ) +import BasicTypes ( IfaceFlavour(..), RecFlag(..) ) +import FieldLabel ( fieldLabelName ) import Id ( GenId, isNullaryDataCon, dataConTag, dataConRawArgTys, fIRST_TAG, - isDataCon, SYN_IE(DataCon), SYN_IE(ConTag), - SYN_IE(Id) ) + isDataCon, DataCon, ConTag, + dataConFieldLabels, Id ) import Maybes ( maybeToBool ) -import Name ( getOccString, getOccName, getSrcLoc, occNameString, modAndOcc, OccName, Name ) +import Name ( getOccString, getOccName, getSrcLoc, occNameString, + modAndOcc, OccName, Name ) import PrimOp ( PrimOp(..) ) import PrelInfo -- Lots of RdrNames import SrcLoc ( mkGeneratedSrcLoc, SrcLoc ) import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon ) -import Type ( eqTy, isPrimType, SYN_IE(Type) ) +import Type ( isUnpointedType, isUnboxedType, Type ) import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy ) -import Util ( mapAccumL, zipEqual, zipWith3Equal, nOfThem, panic, assertPanic ) +import Util ( mapAccumL, zipEqual, zipWithEqual, + zipWith3Equal, nOfThem, panic, assertPanic ) + +import List ( partition, intersperse ) \end{code} %************************************************************************ @@ -260,6 +263,7 @@ cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2) Again, we must be careful about unboxed comparisons. For example, if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to generate: + \begin{verbatim} cmp_eq lt eq gt (O2 a1) (O2 a2) = compareInt# a1 a2 @@ -274,6 +278,9 @@ cmp_eq _ _ = EQ \end{verbatim} \end{itemize} +If there is only one constructor in the Data Type we don't need the WildCard Patern. +JJQC-30-Nov-1997 + \begin{code} gen_Ord_binds :: TyCon -> RdrNameMonoBinds @@ -308,7 +315,10 @@ gen_Ord_binds tycon cmp_eq = mk_FunMonoBind tycon_loc cmp_eq_RDR (map pats_etc nonnullary_cons ++ - [([WildPatIn, WildPatIn], default_rhs)]) + if ((length nonnullary_cons + length nullary_cons) == 1) + then [] + else [([WildPatIn, WildPatIn], + default_rhs)]) where pats_etc data_con = ([con1_pat, con2_pat], @@ -562,7 +572,7 @@ gen_Ix_binds tycon untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(d_RDR, dh_RDR)] ( let - grhs = [OtherwiseGRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc] + grhs = unguardedRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc in HsCase (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR)) @@ -587,26 +597,29 @@ gen_Ix_binds tycon ) tycon_loc)))) -------------------------------------------------------------- - single_con_ixes = single_con_range `AndMonoBinds` - single_con_index `AndMonoBinds` single_con_inRange + single_con_ixes + = single_con_range `AndMonoBinds` + single_con_index `AndMonoBinds` + single_con_inRange data_con = case maybeTyConSingleCon tycon of -- just checking... Nothing -> panic "get_Ix_binds" - Just dc -> if (any isPrimType (dataConRawArgTys dc)) then + Just dc -> if (any isUnpointedType (dataConRawArgTys dc)) then error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str) else dc - con_arity = argFieldCount data_con + con_arity = argFieldCount data_con data_con_RDR = qual_orig_name data_con - con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs) - con_expr xs = mk_easy_App data_con_RDR xs as_needed = take con_arity as_RDRs bs_needed = take con_arity bs_RDRs cs_needed = take con_arity cs_RDRs + con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs) + con_expr = mk_easy_App data_con_RDR cs_needed + -------------------------------------------------------------- single_con_range = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] $ @@ -614,7 +627,7 @@ gen_Ix_binds tycon where stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed ++ - [ReturnStmt (con_expr cs_needed)] + [ReturnStmt con_expr] mk_qual a b c = BindStmt (VarPatIn c) (HsApp (HsVar range_RDR) (ExplicitTuple [HsVar a, HsVar b])) @@ -683,33 +696,74 @@ gen_Read_binds tycon data_con_RDR = qual_orig_name data_con data_con_str= occNameString (getOccName data_con) con_arity = argFieldCount data_con - as_needed = take con_arity as_RDRs - bs_needed = take con_arity bs_RDRs con_expr = mk_easy_App data_con_RDR as_needed nullary_con = con_arity == 0 + labels = dataConFieldLabels data_con + lab_fields = length labels + as_needed = take con_arity as_RDRs + bs_needed + | lab_fields == 0 = take con_arity bs_RDRs + | otherwise = take (4*lab_fields + 1) bs_RDRs + -- (label, '=' and field)*n, (n-1)*',' + '{' + '}' con_qual - = 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) + = BindStmt + (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat]) + (HsApp (HsVar lex_RDR) c_Expr) + tycon_loc + + str_qual str res draw_from + = BindStmt + (TuplePatIn [LitPatIn (HsString str), VarPatIn res]) + (HsApp (HsVar lex_RDR) draw_from) + tycon_loc + + read_label f + = let nm = occNameString (getOccName (fieldLabelName f)) + in + [str_qual nm, str_qual SLIT("=")] + -- There might be spaces between the label and '=' + + field_quals + | lab_fields == 0 = + snd (mapAccumL mk_qual + d_Expr + (zipWithEqual "as_needed" + (\ con_field draw_from -> (mk_read_qual con_field, + draw_from)) + as_needed bs_needed)) + | otherwise = + snd $ + mapAccumL mk_qual d_Expr + (zipEqual "bs_needed" + ((str_qual (SLIT("{")): + concat ( + intersperse ([str_qual (_CONS_ ',' _NIL_)]) $ + zipWithEqual + "field_quals" + (\ as b -> as ++ [b]) + -- The labels + (map read_label labels) + -- The fields + (map mk_read_qual as_needed))) ++ [str_qual (SLIT("}"))]) + bs_needed) + + mk_qual draw_from (f, 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 - ) + f str_left draw_from) + + mk_read_qual con_field res draw_from = + BindStmt + (TuplePatIn [VarPatIn con_field, VarPatIn res]) + (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] + stmts = con_qual:field_quals ++ [ReturnStmt result_expr] - read_paren_arg = if nullary_con then -- must be False (parens are surely optional) false_Expr @@ -721,6 +775,7 @@ gen_Read_binds tycon HsLam (mk_easy_Match tycon_loc [c_Pat] [] $ HsDo ListComp stmts tycon_loc) ) (HsVar b_RDR) + \end{code} %************************************************************************ @@ -748,22 +803,57 @@ gen_Show_binds tycon pats_etc data_con = let data_con_RDR = qual_orig_name data_con - con_arity = argFieldCount data_con - bs_needed = take con_arity bs_RDRs - con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed) - nullary_con = con_arity == 0 + con_arity = argFieldCount data_con + bs_needed = take con_arity bs_RDRs + con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed) + nullary_con = con_arity == 0 + labels = dataConFieldLabels data_con + lab_fields = length labels show_con = let nm = occNameString (getOccName data_con) - space_maybe = if nullary_con then _NIL_ else SLIT(" ") + space_ocurly_maybe + | nullary_con = _NIL_ + | lab_fields == 0 = SLIT(" ") + | otherwise = SLIT("{") + in - HsApp (HsVar showString_RDR) (HsLit (HsString (nm _APPEND_ space_maybe))) + mk_showString_app (nm _APPEND_ space_ocurly_maybe) - show_thingies = show_con : (spacified real_show_thingies) + show_all con fs + = let + ccurly_maybe + | lab_fields > 0 = [mk_showString_app (SLIT("}"))] + | otherwise = [] + in + con:fs ++ ccurly_maybe + + show_thingies = show_all show_con real_show_thingies_with_labs + + show_label l + = let nm = occNameString (getOccName (fieldLabelName l)) + in + mk_showString_app (nm _APPEND_ SLIT("=")) + + mk_showString_app str = HsApp (HsVar showString_RDR) + (HsLit (HsString str)) + + real_show_thingies = + [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b) + | b <- bs_needed ] + + real_show_thingies_with_labs + | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies + | otherwise = --Assumption: no of fields == no of labelled fields + -- (and in same order) + concat $ + intersperse ([mk_showString_app (_CONS_ ',' _NIL_ )]) $ -- Using SLIT() is not cool here. + zipWithEqual "gen_Show_binds" + (\ a b -> [a,b]) + (map show_label labels) + real_show_thingies + - real_show_thingies - = [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b) - | b <- bs_needed ] in if nullary_con then -- skip the showParen junk... ASSERT(null bs_needed) @@ -772,10 +862,6 @@ gen_Show_binds tycon ([a_Pat, con_pat], showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt 10)))) (HsPar (nested_compose_Expr show_thingies))) - where - spacified [] = [] - spacified [x] = [x] - spacified (x:xs) = (x : (HsVar showSpace_RDR) : spacified xs) \end{code} %************************************************************************ @@ -871,7 +957,7 @@ mk_easy_Match loc pats binds expr = mk_match loc pats expr (mkbind binds) where mkbind [] = EmptyBinds - mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] recursive + mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] Recursive -- The renamer expects everything in its input to be a -- "recursive" MonoBinds, and it is its job to sort things out -- from there. @@ -888,7 +974,7 @@ mk_FunMonoBind loc fun pats_and_exprs mk_match loc pats expr binds = foldr PatMatch - (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr loc] binds)) + (GRHSMatch (GRHSsAndBindsIn (unguardedRHS expr loc) binds)) (map paren pats) where paren p@(VarPatIn _) = p @@ -923,17 +1009,17 @@ cmp_eq_Expr = compare_gen_Case cmp_eq_RDR compare_gen_Case fun lt eq gt a b = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-} [PatMatch (ConPatIn ltTag_RDR []) - (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)), + (GRHSMatch (GRHSsAndBindsIn (unguardedRHS lt mkGeneratedSrcLoc) EmptyBinds)), PatMatch (ConPatIn eqTag_RDR []) - (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)), + (GRHSMatch (GRHSsAndBindsIn (unguardedRHS eq mkGeneratedSrcLoc) EmptyBinds)), PatMatch (ConPatIn gtTag_RDR []) - (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))] + (GRHSMatch (GRHSsAndBindsIn (unguardedRHS gt mkGeneratedSrcLoc) EmptyBinds))] mkGeneratedSrcLoc careful_compare_Case ty lt eq gt a b - = if not (isPrimType ty) then + = if not (isUnboxedType ty) then compare_gen_Case compare_RDR lt eq gt a b else -- we have to do something special for primitive things... @@ -949,7 +1035,7 @@ assoc_ty_id tyids ty = if null res then panic "assoc_ty" else head res where - res = [id | (ty',id) <- tyids, eqTy ty ty'] + res = [id | (ty',id) <- tyids, ty == ty'] eq_op_tbl = [(charPrimTy, eqH_Char_RDR) @@ -980,7 +1066,7 @@ 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 + = if not (isUnboxedType ty) then genOpApp a eq_RDR b else -- we have to do something special for primitive things... genOpApp a relevant_eq_op b @@ -1002,7 +1088,7 @@ untag_Expr tycon ((untag_this, put_tag_here) : more) expr (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))] mkGeneratedSrcLoc where - grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc] + grhs = unguardedRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc cmp_tags_Expr :: RdrName -- Comparison op -> RdrName -> RdrName -- Things to compare