X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcGenDeriv.lhs;h=96ac5726f5a20340b74daacaf1c29b4472c71a38;hb=20d387c481324aed48e8469d3fbf0695b3b2e365;hp=4937d47d73264e6e9c33b8c12ff3ae311da28510;hpb=9d38678ea60ff32f756390a30c659daa22c98c93;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 4937d47..96ac572 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -29,42 +29,45 @@ module TcGenDeriv ( import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..), Match(..), GRHSs(..), Stmt(..), HsLit(..), HsBinds(..), StmtCtxt(..), HsType(..), - unguardedRHS, mkSimpleMatch + unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList ) -import RdrHsSyn ( mkOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat ) -import RdrName ( RdrName, mkSrcUnqual ) -import RnMonad ( Fixities ) +import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat ) +import RdrName ( RdrName, mkUnqual ) import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) , maxPrecedence, defaultFixity + , Boxity(..) ) 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 SrcLoc ( generatedSrcLoc, SrcLoc ) import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon, tyConFamilySize ) -import Type ( isUnLiftedType, isUnboxedType, Type ) +import Type ( isUnLiftedType, Type ) import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy ) import Util ( mapAccumL, zipEqual, zipWithEqual, - zipWith3Equal, nOfThem, assocDefault ) + zipWith3Equal, nOfThem ) import Panic ( panic, assertPanic ) -import Maybes ( maybeToBool ) +import Maybes ( maybeToBool, orElse ) import Constants import List ( partition, intersperse ) -import Char ( isAlpha ) +import Outputable ( pprPanic, ppr, pprTrace ) + +#if __GLASGOW_HASKELL__ >= 404 +import GlaExts ( fromInt ) +#endif \end{code} %************************************************************************ @@ -100,7 +103,7 @@ data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ... (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2 \end{verbatim} - Note: if we're comparing unboxed things, e.g., if \tr{a1} and + Note: if we're comparing unlifted things, e.g., if \tr{a1} and \tr{a2} are \tr{Float#}s, then we have to generate \begin{verbatim} case (a1 `eqFloat#` a2) of @@ -199,7 +202,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 @@ -285,7 +288,7 @@ cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2) } \end{verbatim} - Again, we must be careful about unboxed comparisons. For example, + Again, we must be careful about unlifted comparisons. For example, if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to generate: @@ -377,7 +380,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) @@ -396,18 +399,18 @@ gen_Ord_binds tycon defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_] -lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] ( +lt = mk_easy_FunMonoBind generatedSrcLoc lt_RDR [a_Pat, b_Pat] [] ( compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr) -le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] ( +le = mk_easy_FunMonoBind generatedSrcLoc le_RDR [a_Pat, b_Pat] [] ( compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr) -ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] ( +ge = mk_easy_FunMonoBind generatedSrcLoc ge_RDR [a_Pat, b_Pat] [] ( compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr) -gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] ( +gt = mk_easy_FunMonoBind generatedSrcLoc gt_RDR [a_Pat, b_Pat] [] ( compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr) -max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] ( +max_ = mk_easy_FunMonoBind generatedSrcLoc 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] [] ( +min_ = mk_easy_FunMonoBind generatedSrcLoc min_RDR [a_Pat, b_Pat] [] ( compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr) -} \end{code} @@ -561,7 +564,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) @@ -618,7 +621,7 @@ instance ... Ix (Foo ...) where False }}} \end{verbatim} -(modulo suitable case-ification to handle the unboxed tags) +(modulo suitable case-ification to handle the unlifted tags) For a single-constructor type (NB: this includes all tuples), e.g., \begin{verbatim} @@ -644,7 +647,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]) $ @@ -654,7 +657,7 @@ gen_Ix_binds tycon enum_index = mk_easy_FunMonoBind tycon_loc index_RDR - [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] 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)] ( @@ -674,7 +677,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)] ( @@ -693,12 +696,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 @@ -711,7 +714,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 @@ -720,45 +723,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} @@ -769,9 +772,9 @@ gen_Ix_binds tycon %************************************************************************ \begin{code} -gen_Read_binds :: Fixities -> TyCon -> RdrNameMonoBinds +gen_Read_binds :: (Name -> Maybe Fixity) -> TyCon -> RdrNameMonoBinds -gen_Read_binds fixities tycon +gen_Read_binds get_fixity tycon = reads_prec `AndMonoBinds` read_list where tycon_loc = getSrcLoc tycon @@ -784,7 +787,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 @@ -797,7 +800,7 @@ 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 @@ -818,25 +821,25 @@ 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 str_qual_paren str res draw_from = BindStmt - (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] True) + (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed) (HsApp (readParen_Expr true_Expr (HsVar lex_RDR)) draw_from) tycon_loc @@ -891,15 +894,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 is_infix fixities dc_nm + [lp,rp] = getLRPrecs is_infix get_fixity dc_nm quals | is_infix = let (h:t) = field_quals in (h:con_qual:t) @@ -911,12 +914,12 @@ gen_Read_binds fixities tycon c.f. Figure 18 in Haskell 1.1 report. -} paren_prec_limit - | not is_infix = fromInt maxPrecedence - | otherwise = getFixity fixities dc_nm + | not is_infix = defaultPrecedence + | otherwise = getPrecedence get_fixity dc_nm read_paren_arg -- parens depend on precedence... | nullary_con = false_Expr -- it's optional. - | otherwise = HsPar (genOpApp _a_Expr gt_RDR (HsLit (HsInt paren_prec_limit))) + | otherwise = HsPar (genOpApp zz_a_Expr gt_RDR (HsLit (HsInt paren_prec_limit))) \end{code} %************************************************************************ @@ -926,9 +929,9 @@ gen_Read_binds fixities tycon %************************************************************************ \begin{code} -gen_Show_binds :: Fixities -> TyCon -> RdrNameMonoBinds +gen_Show_binds :: (Name -> Maybe Fixity) -> TyCon -> RdrNameMonoBinds -gen_Show_binds fixs_assoc tycon +gen_Show_binds get_fixity tycon = shows_prec `AndMonoBinds` show_list where tycon_loc = getSrcLoc tycon @@ -948,7 +951,7 @@ gen_Show_binds fixs_assoc tycon (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 @@ -999,7 +1002,7 @@ gen_Show_binds fixs_assoc tycon mk_showString_app str = HsApp (HsVar showString_RDR) (HsLit (mkHsString str)) - prec_cons = getLRPrecs is_infix fixs_assoc dc_nm + prec_cons = getLRPrecs is_infix get_fixity dc_nm real_show_thingies | is_infix = @@ -1020,60 +1023,57 @@ 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 = fromInt maxPrecedence + 1 - | otherwise = getFixity fixs_assoc dc_nm + 1 + | not is_infix = defaultPrecedence + 1 + | otherwise = getPrecedence get_fixity dc_nm + 1 \end{code} \begin{code} -getLRPrecs :: Bool -> Fixities -> Name -> [Integer] -getLRPrecs is_infix fixs_assoc nm = [lp, rp] +getLRPrecs :: Bool -> (Name -> Maybe Fixity) -> Name -> [Integer] +getLRPrecs is_infix get_fixity nm = [lp, rp] where {- 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 fixs_assoc nm - paren_con_prec = getFixity fixs_assoc nm - maxPrec = fromInt maxPrecedence + (con_left_assoc, con_right_assoc) = isLRAssoc get_fixity nm + paren_con_prec = getPrecedence get_fixity nm lp - | not is_infix = maxPrec + 1 + | not is_infix = defaultPrecedence + 1 | con_left_assoc = paren_con_prec | otherwise = paren_con_prec + 1 rp - | not is_infix = maxPrec + 1 + | not is_infix = defaultPrecedence + 1 | con_right_assoc = paren_con_prec | otherwise = paren_con_prec + 1 -getFixity :: Fixities -> Name -> Integer -getFixity fixs_assoc nm = - case lookupFixity fixs_assoc nm of - Fixity x _ -> fromInt x - -isLRAssoc :: Fixities -> Name -> (Bool, Bool) -isLRAssoc fixs_assoc nm = - case lookupFixity fixs_assoc nm of +defaultPrecedence :: Integer +defaultPrecedence = fromInt maxPrecedence + +getPrecedence :: (Name -> Maybe Fixity) -> Name -> Integer +getPrecedence get_fixity nm + = case get_fixity nm of + Just (Fixity x _) -> fromInt x + other -> defaultPrecedence + +isLRAssoc :: (Name -> Maybe Fixity) -> Name -> (Bool, Bool) +isLRAssoc get_fixity nm = + case get_fixity nm `orElse` defaultFixity of Fixity _ InfixN -> (False, False) Fixity _ InfixR -> (False, True) Fixity _ InfixL -> (True, False) -lookupFixity :: Fixities -> Name -> Fixity -lookupFixity fixs_assoc nm = assocDefault defaultFixity fixs_assoc nm - isInfixOccName :: String -> Bool isInfixOccName str = case str of (':':_) -> True _ -> False - \end{code} @@ -1088,7 +1088,7 @@ data Foo ... = ... con2tag_Foo :: Foo ... -> Int# tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# -maxtag_Foo :: Int -- ditto (NB: not unboxed) +maxtag_Foo :: Int -- ditto (NB: not unlifted) \end{verbatim} The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) @@ -1119,14 +1119,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 [([ConPatIn mkInt_RDR [VarPatIn a_RDR]], ExprWithTySig (HsApp tagToEnum_Expr a_Expr) - (MonoTyVar (qual_orig_name tycon)))] + (HsTyVar (qual_orig_name tycon)))] gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag) = mk_easy_FunMonoBind (getSrcLoc tycon) @@ -1166,10 +1166,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. @@ -1220,20 +1217,20 @@ cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b compare_gen_Case fun lt eq gt a b = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-} - [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing mkGeneratedSrcLoc, - mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing mkGeneratedSrcLoc, - mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing mkGeneratedSrcLoc] - mkGeneratedSrcLoc + [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing generatedSrcLoc, + mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing generatedSrcLoc, + mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing generatedSrcLoc] + generatedSrcLoc careful_compare_Case ty lt eq gt a b - = if not (isUnboxedType ty) then + = if not (isUnLiftedType ty) then compare_gen_Case compare_RDR lt eq gt a b else -- we have to do something special for primitive things... HsIf (genOpApp a relevant_eq_op b) eq - (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc) - mkGeneratedSrcLoc + (HsIf (genOpApp a relevant_lt_op b) lt gt generatedSrcLoc) + generatedSrcLoc where relevant_eq_op = assoc_ty_id eq_op_tbl ty relevant_lt_op = assoc_ty_id lt_op_tbl ty @@ -1273,7 +1270,7 @@ append_Expr a b = genOpApp a append_RDR b eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr eq_Expr ty a b - = if not (isUnboxedType ty) then + = if not (isUnLiftedType ty) then genOpApp a eq_RDR b else -- we have to do something special for primitive things... genOpApp a relevant_eq_op b @@ -1282,17 +1279,12 @@ 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 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-} - [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) Nothing mkGeneratedSrcLoc] - mkGeneratedSrcLoc + [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) Nothing generatedSrcLoc] + generatedSrcLoc cmp_tags_Expr :: RdrName -- Comparison op -> RdrName -> RdrName -- Things to compare @@ -1301,7 +1293,7 @@ cmp_tags_Expr :: RdrName -- Comparison op -> RdrNameHsExpr cmp_tags_Expr op a b true_case false_case - = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc + = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case generatedSrcLoc enum_from_to_Expr :: RdrNameHsExpr -> RdrNameHsExpr @@ -1362,14 +1354,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 -_a_RDR = varUnqual SLIT("_a") +zz_a_RDR = varUnqual SLIT("_a") a_RDR = varUnqual SLIT("a") b_RDR = varUnqual SLIT("b") c_RDR = varUnqual SLIT("c") @@ -1387,7 +1379,7 @@ cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ] mkHsString s = HsString (_PK_ s) -_a_Expr = HsVar _a_RDR +zz_a_Expr = HsVar zz_a_RDR a_Expr = HsVar a_RDR b_Expr = HsVar b_RDR c_Expr = HsVar c_RDR @@ -1403,7 +1395,7 @@ tagToEnum_Expr = HsVar tagToEnumH_RDR con2tag_Expr tycon = HsVar (con2tag_RDR tycon) wildPat = WildPatIn -_a_Pat = VarPatIn _a_RDR +zz_a_Pat = VarPatIn zz_a_RDR a_Pat = VarPatIn a_RDR b_Pat = VarPatIn b_RDR c_Pat = VarPatIn c_RDR