X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcGenDeriv.lhs;h=bf828e4a9683e4f501f1ba2d0d90784dcbb21f73;hb=2540a99f8e67237f7fa9cd49143ae2cd9d7f84d6;hp=77f3c4276b9ede60bae43080c0935a7ab288d095;hpb=aae367819798b0883de61ea4d91ea2c47452884e;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 77f3c42..bf828e4 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -28,24 +28,26 @@ module TcGenDeriv ( import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..), Match(..), GRHSs(..), Stmt(..), HsLit(..), - HsBinds(..), StmtCtxt(..), - unguardedRHS, mkSimpleMatch + HsBinds(..), StmtCtxt(..), HsType(..), + unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList + ) +import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat ) +import RdrName ( RdrName, mkUnqual ) +import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) + , maxPrecedence + , Boxity(..) ) -import RdrHsSyn ( mkOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat ) -import RdrName ( RdrName, mkSrcUnqual ) -import RnMonad ( Fixities ) -import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) ) import FieldLabel ( fieldLabelName ) import DataCon ( isNullaryDataCon, dataConTag, - dataConRawArgTys, fIRST_TAG, - DataCon, ConTag, + dataConOrigArgTys, dataConSourceArity, fIRST_TAG, + DataCon, dataConFieldLabels ) import Name ( getOccString, getOccName, getSrcLoc, occNameString, occNameUserString, nameRdrName, varName, - OccName, Name, NamedThing(..), NameSpace + Name, NamedThing(..), + isDataSymOcc, isSymOcc ) -import PrimOp ( PrimOp(..) ) import PrelInfo -- Lots of RdrNames import SrcLoc ( mkGeneratedSrcLoc, SrcLoc ) import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, @@ -58,9 +60,13 @@ import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, import Util ( mapAccumL, zipEqual, zipWithEqual, zipWith3Equal, nOfThem ) import Panic ( panic, assertPanic ) -import Maybes ( maybeToBool, assocMaybe ) +import Maybes ( maybeToBool ) import Constants import List ( partition, intersperse ) + +#if __GLASGOW_HASKELL__ >= 404 +import GlaExts ( fromInt ) +#endif \end{code} %************************************************************************ @@ -174,7 +180,7 @@ gen_Eq_binds tycon case maybeTyConSingleCon tycon of Just _ -> [] Nothing -> -- if cons don't match, then False - [([a_Pat, b_Pat], false_Expr)] + [([wildPat, wildPat], false_Expr)] else -- calc. and compare the tags [([a_Pat, b_Pat], untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] @@ -195,7 +201,7 @@ gen_Eq_binds tycon con_arity = length tys_needed as_needed = take con_arity as_RDRs bs_needed = take con_arity bs_RDRs - tys_needed = dataConRawArgTys data_con + tys_needed = dataConOrigArgTys data_con in ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed) where @@ -306,7 +312,8 @@ JJQC-30-Nov-1997 gen_Ord_binds :: TyCon -> RdrNameMonoBinds gen_Ord_binds tycon - = defaulted `AndMonoBinds` compare + = compare -- `AndMonoBinds` compare + -- The default declaration in PrelBase handles this where tycon_loc = getSrcLoc tycon -------------------------------------------------------------------- @@ -372,7 +379,7 @@ gen_Ord_binds tycon con_arity = length tys_needed as_needed = take con_arity as_RDRs bs_needed = take con_arity bs_RDRs - tys_needed = dataConRawArgTys data_con + tys_needed = dataConOrigArgTys data_con nested_compare_expr [ty] [a] [b] = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b) @@ -387,6 +394,8 @@ gen_Ord_binds tycon -- Tags are equal, no args => return EQ -------------------------------------------------------------------- +{- Not necessary: the default decls in PrelBase handle these + defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_] lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] ( @@ -402,6 +411,7 @@ max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] ( compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr) min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] ( compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr) +-} \end{code} %************************************************************************ @@ -553,7 +563,7 @@ gen_Bounded_binds tycon data_con_N_RDR = qual_orig_name data_con_N ----- single-constructor-flavored: ------------- - arity = argFieldCount data_con_1 + arity = dataConSourceArity data_con_1 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $ mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR) @@ -636,7 +646,7 @@ gen_Ix_binds tycon enum_range = mk_easy_FunMonoBind tycon_loc range_RDR - [TuplePatIn [a_Pat, b_Pat] True{-boxed-}] [] $ + [TuplePatIn [a_Pat, b_Pat] Boxed] [] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ untag_Expr tycon [(b_RDR, bh_RDR)] $ HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $ @@ -646,7 +656,7 @@ gen_Ix_binds tycon enum_index = mk_easy_FunMonoBind tycon_loc index_RDR - [AsPatIn c_RDR (TuplePatIn [a_Pat, b_Pat] True{-boxed-}), + [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] Boxed), d_Pat] [] ( HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) ( untag_Expr tycon [(a_RDR, ah_RDR)] ( @@ -666,7 +676,7 @@ gen_Ix_binds tycon enum_inRange = mk_easy_FunMonoBind tycon_loc inRange_RDR - [TuplePatIn [a_Pat, b_Pat] True{-boxed-}, c_Pat] [] ( + [TuplePatIn [a_Pat, b_Pat] Boxed, c_Pat] [] ( untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(b_RDR, bh_RDR)] ( untag_Expr tycon [(c_RDR, ch_RDR)] ( @@ -685,12 +695,12 @@ gen_Ix_binds tycon data_con = case maybeTyConSingleCon tycon of -- just checking... Nothing -> panic "get_Ix_binds" - Just dc -> if (any isUnLiftedType (dataConRawArgTys dc)) then + Just dc -> if (any isUnLiftedType (dataConOrigArgTys 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 = dataConSourceArity data_con data_con_RDR = qual_orig_name data_con as_needed = take con_arity as_RDRs @@ -703,7 +713,7 @@ gen_Ix_binds tycon -------------------------------------------------------------- single_con_range = mk_easy_FunMonoBind tycon_loc range_RDR - [TuplePatIn [con_pat as_needed, con_pat bs_needed] True{-boxed-}] [] $ + [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed] [] $ HsDo ListComp stmts tycon_loc where stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed @@ -712,45 +722,45 @@ gen_Ix_binds tycon mk_qual a b c = BindStmt (VarPatIn c) (HsApp (HsVar range_RDR) - (ExplicitTuple [HsVar a, HsVar b] True)) + (ExplicitTuple [HsVar a, HsVar b] Boxed)) tycon_loc ---------------- single_con_index = mk_easy_FunMonoBind tycon_loc index_RDR - [TuplePatIn [con_pat as_needed, con_pat bs_needed] True, + [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] [range_size] ( foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed)) where mk_index multiply_by (l, u, i) = genOpApp ( (HsApp (HsApp (HsVar index_RDR) - (ExplicitTuple [HsVar l, HsVar u] True)) (HsVar i)) + (ExplicitTuple [HsVar l, HsVar u] Boxed)) (HsVar i)) ) plus_RDR ( genOpApp ( (HsApp (HsVar rangeSize_RDR) - (ExplicitTuple [HsVar l, HsVar u] True)) + (ExplicitTuple [HsVar l, HsVar u] Boxed)) ) times_RDR multiply_by ) range_size = mk_easy_FunMonoBind tycon_loc rangeSize_RDR - [TuplePatIn [a_Pat, b_Pat] True] [] ( + [TuplePatIn [a_Pat, b_Pat] Boxed] [] ( genOpApp ( (HsApp (HsApp (HsVar index_RDR) - (ExplicitTuple [a_Expr, b_Expr] True)) b_Expr) + (ExplicitTuple [a_Expr, b_Expr] Boxed)) b_Expr) ) plus_RDR (HsLit (HsInt 1))) ------------------ single_con_inRange = mk_easy_FunMonoBind tycon_loc inRange_RDR - [TuplePatIn [con_pat as_needed, con_pat bs_needed] True, + [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed, 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 = HsApp (HsApp (HsVar inRange_RDR) - (ExplicitTuple [HsVar a, HsVar b] True)) + (ExplicitTuple [HsVar a, HsVar b] Boxed)) (HsVar c) \end{code} @@ -761,9 +771,9 @@ gen_Ix_binds tycon %************************************************************************ \begin{code} -gen_Read_binds :: Fixities -> TyCon -> RdrNameMonoBinds +gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds -gen_Read_binds fixities tycon +gen_Read_binds gst tycon = reads_prec `AndMonoBinds` read_list where tycon_loc = getSrcLoc tycon @@ -776,7 +786,7 @@ gen_Read_binds fixities tycon read_con_comprehensions = map read_con (tyConDataCons tycon) in - mk_easy_FunMonoBind tycon_loc readsPrec_RDR [a_Pat, b_Pat] [] ( + mk_easy_FunMonoBind tycon_loc readsPrec_RDR [zz_a_Pat, b_Pat] [] ( foldr1 append_Expr read_con_comprehensions ) where @@ -789,15 +799,15 @@ gen_Read_binds fixities tycon where data_con_RDR = qual_orig_name data_con data_con_str = occNameUserString (getOccName data_con) - con_arity = argFieldCount data_con + con_arity = dataConSourceArity data_con con_expr = mk_easy_App data_con_RDR as_needed nullary_con = con_arity == 0 labels = dataConFieldLabels data_con lab_fields = length labels dc_nm = getName data_con - is_infix = isInfixOccName data_con_str + is_infix = isDataSymOcc (getOccName dc_nm) - as_needed = take con_arity as_RDRs + as_needed = take con_arity as_RDRs bs_needed | is_infix = take (1 + con_arity) bs_RDRs | lab_fields == 0 = take con_arity bs_RDRs @@ -810,26 +820,38 @@ gen_Read_binds fixities tycon con_qual | not is_infix = BindStmt - (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] True) + (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] Boxed) (HsApp (HsVar lex_RDR) c_Expr) tycon_loc | otherwise = BindStmt - (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] True) + (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] Boxed) (HsApp (HsVar lex_RDR) (HsVar bs1)) tycon_loc str_qual str res draw_from = BindStmt - (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] True) + (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed) (HsApp (HsVar lex_RDR) draw_from) tycon_loc - read_label f = [str_qual nm, str_qual "="] + str_qual_paren str res draw_from = + BindStmt + (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed) + (HsApp (readParen_Expr true_Expr (HsVar lex_RDR)) draw_from) + tycon_loc + + read_label f = [rd_lab, str_qual "="] -- There might be spaces between the label and '=' where - nm = occNameUserString (getOccName (fieldLabelName f)) + rd_lab + | is_op = str_qual_paren nm + | otherwise = str_qual nm + + occ_nm = getOccName (fieldLabelName f) + is_op = isSymOcc occ_nm + nm = occNameUserString occ_nm field_quals | is_infix = @@ -840,14 +862,14 @@ gen_Read_binds fixities tycon ]) | lab_fields == 0 = -- common case. snd (mapAccumL mk_qual - c_Expr + d_Expr (zipWithEqual "as_needed" (\ con_field draw_from -> (mk_read_qual 10 con_field, draw_from)) as_needed bs_needed)) | otherwise = snd $ - mapAccumL mk_qual c_Expr + mapAccumL mk_qual d_Expr (zipEqual "bs_needed" ((str_qual "{": concat ( @@ -871,15 +893,15 @@ gen_Read_binds fixities tycon mk_read_qual p con_field res draw_from = BindStmt - (TuplePatIn [VarPatIn con_field, VarPatIn res] True) + (TuplePatIn [VarPatIn con_field, VarPatIn res] Boxed) (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from) tycon_loc result_expr = ExplicitTuple [con_expr, if null bs_needed then d_Expr - else HsVar (last bs_needed)] True + else HsVar (last bs_needed)] Boxed - [lp,rp] = getLRPrecs fixities dc_nm + [lp,rp] = getLRPrecs is_infix gst dc_nm quals | is_infix = let (h:t) = field_quals in (h:con_qual:t) @@ -887,13 +909,16 @@ gen_Read_binds fixities tycon stmts = quals ++ [ReturnStmt result_expr] + {- + c.f. Figure 18 in Haskell 1.1 report. + -} paren_prec_limit - | not is_infix = 9 - | otherwise = getFixity fixities dc_nm - - read_paren_arg = -- parens depend on precedence... - HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt paren_prec_limit))) + | not is_infix = fromInt maxPrecedence + | otherwise = getFixity gst dc_nm + read_paren_arg -- parens depend on precedence... + | nullary_con = false_Expr -- it's optional. + | otherwise = HsPar (genOpApp zz_a_Expr gt_RDR (HsLit (HsInt paren_prec_limit))) \end{code} %************************************************************************ @@ -903,9 +928,9 @@ gen_Read_binds fixities tycon %************************************************************************ \begin{code} -gen_Show_binds :: Fixities -> TyCon -> RdrNameMonoBinds +gen_Show_binds :: GlobalSymbolTable -> TyCon -> RdrNameMonoBinds -gen_Show_binds fixs_assoc tycon +gen_Show_binds gst tycon = shows_prec `AndMonoBinds` show_list where tycon_loc = getSrcLoc tycon @@ -918,36 +943,36 @@ gen_Show_binds fixs_assoc tycon pats_etc data_con | nullary_con = -- skip the showParen junk... ASSERT(null bs_needed) - ([a_Pat, con_pat], show_con) + ([wildPat, con_pat], show_con) | otherwise = ([a_Pat, con_pat], - showParen_Expr (HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt paren_prec_limit)))) + showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt paren_prec_limit)))) (HsPar (nested_compose_Expr show_thingies))) where data_con_RDR = qual_orig_name data_con - con_arity = argFieldCount data_con + con_arity = dataConSourceArity 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 - dc_occ_nm = occNameUserString (getOccName data_con) - dc_nm = getName data_con + dc_nm = getName data_con + dc_occ_nm = getOccName data_con + dc_occ_nm_str = occNameUserString dc_occ_nm - is_infix = isInfixOccName dc_occ_nm + is_infix = isDataSymOcc dc_occ_nm show_con - | is_infix = mk_showString_app (' ':dc_occ_nm) - | otherwise = - let + | is_infix = mk_showString_app (' ':dc_occ_nm_str) + | otherwise = mk_showString_app (dc_occ_nm_str ++ space_ocurly_maybe) + where space_ocurly_maybe | nullary_con = "" | lab_fields == 0 = " " | otherwise = "{" - in - mk_showString_app (dc_occ_nm ++ space_ocurly_maybe) + show_all con fs@(x:xs) | is_infix = x:con:xs @@ -961,15 +986,22 @@ gen_Show_binds fixs_assoc tycon show_thingies = show_all show_con real_show_thingies_with_labs - show_label l = mk_showString_app (nm ++ "=") + show_label l = mk_showString_app (the_name ++ "=") where - nm = occNameUserString (getOccName (fieldLabelName l)) + occ_nm = getOccName (fieldLabelName l) + -- legal, but rare. + is_op = isSymOcc occ_nm + the_name + | is_op = '(':nm ++ ")" + | otherwise = nm + + nm = occNameUserString occ_nm mk_showString_app str = HsApp (HsVar showString_RDR) (HsLit (mkHsString str)) - prec_cons = getLRPrecs fixs_assoc dc_nm + prec_cons = getLRPrecs is_infix gst dc_nm real_show_thingies | is_infix = @@ -990,49 +1022,53 @@ gen_Show_binds fixs_assoc tycon (map show_label labels) real_show_thingies - (con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc dc_nm - + {- + c.f. Figure 16 and 17 in Haskell 1.1 report + -} paren_prec_limit - | not is_infix = 9 - | otherwise = getFixity fixs_assoc dc_nm + | not is_infix = fromInt maxPrecedence + 1 + | otherwise = getFixity gst dc_nm + 1 \end{code} \begin{code} -getLRPrecs :: Fixities -> Name -> [Integer] -getLRPrecs fixs_assoc nm = [lp, rp] +getLRPrecs :: Bool -> GlobalSymbolTable -> Name -> [Integer] +getLRPrecs is_infix gst nm = [lp, rp] where - ( con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc nm - paren_prec_limit = 9 + {- + Figuring out the fixities of the arguments to a constructor, + cf. Figures 16-18 in Haskell 1.1 report. + -} + (con_left_assoc, con_right_assoc) = isLRAssoc gst nm + paren_con_prec = getFixity gst nm + maxPrec = fromInt maxPrecedence lp - | con_left_assoc = paren_prec_limit - | otherwise = paren_prec_limit + 1 + | not is_infix = maxPrec + 1 + | con_left_assoc = paren_con_prec + | otherwise = paren_con_prec + 1 rp - | con_right_assoc = paren_prec_limit - | otherwise = paren_prec_limit + 1 + | not is_infix = maxPrec + 1 + | con_right_assoc = paren_con_prec + | otherwise = paren_con_prec + 1 +getFixity :: GobalSymbolTable -> Name -> Integer +getFixity gst nm = case lookupFixityEnv gst nm of + Fixity x _ -> fromInt x -getFixity :: Fixities -> Name -> Integer -getFixity fixs_assoc nm = - case assocMaybe fixs_assoc nm of - Nothing -> 9 - Just (Fixity x _) -> fromInt x + 1 - -isLRAssoc :: Fixities -> Name -> (Bool, Bool) +isLRAssoc :: FixityEnv -> Name -> (Bool, Bool) isLRAssoc fixs_assoc nm = - case assocMaybe fixs_assoc nm of - Just (Fixity _ InfixL) -> (True, False) - Just (Fixity _ InfixR) -> (False, True) - _ -> (False, False) + case lookupFixity fixs_assoc nm of + Fixity _ InfixN -> (False, False) + Fixity _ InfixR -> (False, True) + Fixity _ InfixL -> (True, False) isInfixOccName :: String -> Bool isInfixOccName str = case str of (':':_) -> True _ -> False - \end{code} @@ -1078,20 +1114,14 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) mk_stuff var = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))) where - pat = ConPatIn var_RDR (nOfThem (argFieldCount var) WildPatIn) + pat = ConPatIn var_RDR (nOfThem (dataConSourceArity var) WildPatIn) 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) ++ - [([WildPatIn], impossible_Expr)]) - where - mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr) - mk_stuff var = ([lit_pat], HsVar var_RDR) - where - lit_pat = ConPatIn mkInt_RDR [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))] - var_RDR = qual_orig_name var + = mk_FunMonoBind (getSrcLoc tycon) rdr_name + [([ConPatIn mkInt_RDR [VarPatIn a_RDR]], + ExprWithTySig (HsApp tagToEnum_Expr a_Expr) + (HsTyVar (qual_orig_name tycon)))] gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag) = mk_easy_FunMonoBind (getSrcLoc tycon) @@ -1131,10 +1161,7 @@ mk_easy_FunMonoBind loc fun pats binds expr = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc mk_easy_Match loc pats binds expr - = mk_match loc pats expr (mkbind binds) - where - mkbind [] = EmptyBinds - mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] Recursive + = mk_match loc pats expr (mkMonoBind (andMonoBindList binds) [] Recursive) -- The renamer expects everything in its input to be a -- "recursive" MonoBinds, and it is its job to sort things out -- from there. @@ -1247,11 +1274,6 @@ eq_Expr ty a b \end{code} \begin{code} -argFieldCount :: DataCon -> Int -- Works on data and newtype constructors -argFieldCount con = length (dataConRawArgTys con) -\end{code} - -\begin{code} untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr untag_Expr tycon [] expr = expr untag_Expr tycon ((untag_this, put_tag_here) : more) expr @@ -1327,13 +1349,14 @@ parenify e = HsPar e -- 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 +genOpApp e1 op e2 = mkHsOpApp e1 op e2 \end{code} \begin{code} qual_orig_name n = nameRdrName (getName n) -varUnqual n = mkSrcUnqual varName n +varUnqual n = mkUnqual varName n +zz_a_RDR = varUnqual SLIT("_a") a_RDR = varUnqual SLIT("a") b_RDR = varUnqual SLIT("b") c_RDR = varUnqual SLIT("c") @@ -1351,6 +1374,7 @@ cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ] mkHsString s = HsString (_PK_ s) +zz_a_Expr = HsVar zz_a_RDR a_Expr = HsVar a_RDR b_Expr = HsVar b_RDR c_Expr = HsVar c_RDR @@ -1362,14 +1386,17 @@ false_Expr = HsVar false_RDR true_Expr = HsVar true_RDR getTag_Expr = HsVar getTag_RDR +tagToEnum_Expr = HsVar tagToEnumH_RDR con2tag_Expr tycon = HsVar (con2tag_RDR tycon) +wildPat = WildPatIn +zz_a_Pat = VarPatIn zz_a_RDR a_Pat = VarPatIn a_RDR b_Pat = VarPatIn b_RDR c_Pat = VarPatIn c_RDR d_Pat = VarPatIn d_RDR -tag2con_RDR, maxtag_RDR :: TyCon -> RdrName +con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName con2tag_RDR tycon = varUnqual (_PK_ ("con2tag_" ++ occNameString (getOccName tycon) ++ "#")) tag2con_RDR tycon = varUnqual (_PK_ ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))