X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcGenDeriv.lhs;h=ea9a33fb0941159bb17f9f3192bd6826eb58cf21;hp=ea5ca8eb92ca1343b48cb2efde026a6eb461c97c;hb=d107207d57f6102f580578e7c168b7317b04b9c4;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index ea5ca8e..ea9a33f 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -11,14 +11,9 @@ This module is nominally ``subordinate'' to @TcDeriv@, which is the This is where we do all the grimy bindings' generation. \begin{code} -{-# OPTIONS_GHC -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings --- for details - module TcGenDeriv ( + DerivAuxBind(..), DerivAuxBinds, isDupAux, + gen_Bounded_binds, gen_Enum_binds, gen_Eq_binds, @@ -28,11 +23,9 @@ module TcGenDeriv ( gen_Show_binds, gen_Data_binds, gen_Typeable_binds, - gen_tag_n_con_monobind, - - con2tag_RDR, tag2con_RDR, maxtag_RDR, + genAuxBind, - TagThingWanted(..) + con2tag_RDR, tag2con_RDR, maxtag_RDR ) where #include "HsVersions.h" @@ -62,15 +55,26 @@ import Bag import Data.List ( partition, intersperse ) \end{code} -%************************************************************************ -%* * -\subsection{Generating code, by derivable class} -%* * -%************************************************************************ +\begin{code} +type DerivAuxBinds = [DerivAuxBind] + +data DerivAuxBind -- Please add these auxiliary top-level bindings + = DerivAuxBind (LHsBind RdrName) + | GenCon2Tag TyCon -- The con2Tag for given TyCon + | GenTag2Con TyCon -- ...ditto tag2Con + | GenMaxTag TyCon -- ...and maxTag + +isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool +isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1 == tc2 +isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1 == tc2 +isDupAux (GenMaxTag tc1) (GenMaxTag tc2) = tc1 == tc2 +isDupAux _ _ = False +\end{code} + %************************************************************************ %* * -\subsubsection{Generating @Eq@ instance declarations} + Eq instances %* * %************************************************************************ @@ -143,33 +147,36 @@ instance ... Eq (Foo ...) where \begin{code} -gen_Eq_binds :: TyCon -> LHsBinds RdrName - +gen_Eq_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Eq_binds tycon - = let - tycon_loc = getSrcSpan tycon - - (nullary_cons, nonnullary_cons) - | isNewTyCon tycon = ([], tyConDataCons tycon) - | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon) - - rest - = if (null nullary_cons) then - case maybeTyConSingleCon tycon of - Just _ -> [] - Nothing -> -- if cons don't match, then False - [([nlWildPat, nlWildPat], false_Expr)] - else -- calc. and compare the tags - [([a_Pat, b_Pat], - untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] - (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] - in - listToBag [ - mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest), - mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] ( - nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR]))) - ] + = (method_binds, aux_binds) where + tycon_loc = getSrcSpan tycon + + (nullary_cons, nonnullary_cons) + | isNewTyCon tycon = ([], tyConDataCons tycon) + | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon) + + no_nullary_cons = null nullary_cons + + rest | no_nullary_cons + = case maybeTyConSingleCon tycon of + Just _ -> [] + Nothing -> -- if cons don't match, then False + [([nlWildPat, nlWildPat], false_Expr)] + | otherwise -- calc. and compare the tags + = [([a_Pat, b_Pat], + untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] + (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] + + aux_binds | no_nullary_cons = [] + | otherwise = [GenCon2Tag tycon] + + method_binds = listToBag [ + mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest), + mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] ( + nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))] + ------------------------------------------------------------------ pats_etc data_con = let @@ -193,7 +200,7 @@ gen_Eq_binds tycon %************************************************************************ %* * -\subsubsection{Generating @Ord@ instance declarations} + Ord instances %* * %************************************************************************ @@ -288,14 +295,21 @@ If there is only one constructor in the Data Type we don't need the WildCard Pat JJQC-30-Nov-1997 \begin{code} -gen_Ord_binds :: TyCon -> LHsBinds RdrName +gen_Ord_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Ord_binds tycon - = unitBag compare -- `AndMonoBinds` compare - -- The default declaration in PrelBase handles this + | Just (con, prim_tc) <- primWrapperType_maybe tycon + = gen_PrimOrd_binds con prim_tc + + | otherwise + = (unitBag compare, aux_binds) + -- `AndMonoBinds` compare + -- The default declaration in PrelBase handles this where tycon_loc = getSrcSpan tycon -------------------------------------------------------------------- + aux_binds | single_con_type = [] + | otherwise = [GenCon2Tag tycon] compare = L tycon_loc (mkFunBind (L tycon_loc compare_RDR) compare_matches) compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds] @@ -333,38 +347,88 @@ gen_Ord_binds tycon else [([nlWildPat, nlWildPat], default_rhs)]) - where - 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 + 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 + 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 + 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] [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 + 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 + nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length +\end{code} + +Note [Comparision of primitive types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The general plan does not work well for data types like + data T = MkT Int# deriving( Ord ) +The general plan defines the 'compare' method, gets (<) etc from it. But +that means we get silly code like: + instance Ord T where + (>) (I# x) (I# y) = case <# x y of + True -> False + False -> case ==# x y of + True -> False + False -> True +We would prefer to use the (>#) primop. See also Trac #2130 + - 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 +\begin{code} +gen_PrimOrd_binds :: DataCon -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +-- See Note [Comparison of primitive types] +gen_PrimOrd_binds data_con prim_tc + = (listToBag [mk_op lt_RDR lt_op, mk_op le_RDR le_op, + mk_op ge_RDR ge_op, mk_op gt_RDR gt_op], []) + where + mk_op op_RDR op = mk_FunBind (getSrcSpan data_con) op_RDR + [([apat, bpat], genOpApp a_Expr (primOpRdrName op) b_Expr)] + con_RDR = getRdrName data_con + apat = nlConVarPat con_RDR [a_RDR] + bpat = nlConVarPat con_RDR [b_RDR] + + (lt_op, le_op, ge_op, gt_op) + | prim_tc == charPrimTyCon = (CharLtOp, CharLeOp, CharGeOp, CharGtOp) + | prim_tc == intPrimTyCon = (IntLtOp, IntLeOp, IntGeOp, IntGtOp) + | prim_tc == wordPrimTyCon = (WordLtOp, WordLeOp, WordGeOp, WordGtOp) + | prim_tc == addrPrimTyCon = (AddrLtOp, AddrLeOp, AddrGeOp, AddrGtOp) + | prim_tc == floatPrimTyCon = (FloatLtOp, FloatLeOp, FloatGeOp, FloatGtOp) + | prim_tc == doublePrimTyCon = (DoubleLtOp, DoubleLeOp, DoubleGeOp, DoubleGtOp) + | otherwise = pprPanic "Unexpected primitive tycon" (ppr prim_tc) + + +primWrapperType_maybe :: TyCon -> Maybe (DataCon, TyCon) +-- True of data types that are wrappers around prmitive types +-- data T = MkT Word# +-- For these we want to generate all the (<), (<=) etc operations individually +primWrapperType_maybe tc + | [con] <- tyConDataCons tc + , [ty] <- dataConOrigArgTys con + , Just (prim_tc, []) <- tcSplitTyConApp_maybe ty + , isPrimTyCon prim_tc + = Just (con, prim_tc) + | otherwise + = Nothing \end{code} %************************************************************************ %* * -\subsubsection{Generating @Enum@ instance declarations} + Enum instances %* * %************************************************************************ @@ -404,18 +468,20 @@ instance ... Enum (Foo ...) where For @enumFromTo@ and @enumFromThenTo@, we use the default methods. \begin{code} -gen_Enum_binds :: TyCon -> LHsBinds RdrName - +gen_Enum_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Enum_binds tycon - = listToBag [ - succ_enum, - pred_enum, - to_enum, - enum_from, - enum_from_then, - from_enum - ] + = (method_binds, aux_binds) where + method_binds = listToBag [ + succ_enum, + pred_enum, + to_enum, + enum_from, + enum_from_then, + from_enum + ] + aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon] + tycon_loc = getSrcSpan tycon occ_nm = getOccString tycon @@ -477,17 +543,18 @@ gen_Enum_binds tycon %************************************************************************ %* * -\subsubsection{Generating @Bounded@ instance declarations} + Bounded instances %* * %************************************************************************ \begin{code} +gen_Bounded_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Bounded_binds tycon - = if isEnumerationTyCon tycon then - listToBag [ min_bound_enum, max_bound_enum ] - else - ASSERT(isSingleton data_cons) - listToBag [ min_bound_1con, max_bound_1con ] + | isEnumerationTyCon tycon + = (listToBag [ min_bound_enum, max_bound_enum ], []) + | otherwise + = ASSERT(isSingleton data_cons) + (listToBag [ min_bound_1con, max_bound_1con ], []) where data_cons = tyConDataCons tycon tycon_loc = getSrcSpan tycon @@ -512,7 +579,7 @@ gen_Bounded_binds tycon %************************************************************************ %* * -\subsubsection{Generating @Ix@ instance declarations} + Ix instances %* * %************************************************************************ @@ -569,12 +636,13 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report (p.~147). \begin{code} -gen_Ix_binds :: TyCon -> LHsBinds RdrName +gen_Ix_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Ix_binds tycon - = if isEnumerationTyCon tycon - then enum_ixes - else single_con_ixes + | isEnumerationTyCon tycon + = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]) + | otherwise + = (single_con_ixes, [GenCon2Tag tycon]) where tycon_loc = getSrcSpan tycon @@ -655,7 +723,11 @@ gen_Ix_binds tycon = mk_easy_FunBind tycon_loc unsafeIndex_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] - (mk_index (zip3 as_needed bs_needed cs_needed)) + -- We need to reverse the order we consider the components in + -- so that + -- range (l,u) !! index (l,u) i == i -- when i is in range + -- (from http://haskell.org/onlinereport/ix.html) holds. + (mk_index (reverse $ zip3 as_needed bs_needed cs_needed)) where -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...) mk_index [] = nlHsIntLit 0 @@ -685,7 +757,7 @@ gen_Ix_binds tycon %************************************************************************ %* * -\subsubsection{Generating @Read@ instance declarations} + Read instances %* * %************************************************************************ @@ -728,10 +800,10 @@ instance Read T where \begin{code} -gen_Read_binds :: FixityEnv -> TyCon -> LHsBinds RdrName +gen_Read_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Read_binds get_fixity tycon - = listToBag [read_prec, default_readlist, default_readlistprec] + = (listToBag [read_prec, default_readlist, default_readlistprec], []) where ----------------------------------------------------------------------- default_readlist @@ -853,7 +925,7 @@ gen_Read_binds get_fixity tycon %************************************************************************ %* * -\subsubsection{Generating @Show@ instance declarations} + Show instances %* * %************************************************************************ @@ -881,10 +953,10 @@ Example -- the most tightly-binding operator \begin{code} -gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName +gen_Show_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Show_binds get_fixity tycon - = listToBag [shows_prec, show_list] + = (listToBag [shows_prec, show_list], []) where tycon_loc = getSrcSpan tycon ----------------------------------------------------------------------- @@ -966,9 +1038,10 @@ wrapOpBackquotes s | isSym s = s | otherwise = '`' : s ++ "`" isSym :: String -> Bool -isSym "" = False -isSym (c:cs) = startsVarSym c || startsConSym c +isSym "" = False +isSym (c : _) = startsVarSym c || startsConSym c +mk_showString_app :: String -> LHsExpr RdrName mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str)) \end{code} @@ -986,7 +1059,10 @@ appPrecedence = fromIntegral maxPrecedence + 1 getPrecedence :: FixityEnv -> Name -> Integer getPrecedence get_fixity nm = case lookupFixity get_fixity nm of - Fixity x _ -> fromIntegral x + Fixity x _assoc -> fromIntegral x + -- NB: the Report says that associativity is not taken + -- into account for either Read or Show; hence we + -- ignore associativity here \end{code} @@ -1032,7 +1108,7 @@ mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix)) %************************************************************************ %* * -\subsection{Data} + Data instances %* * %************************************************************************ @@ -1065,11 +1141,11 @@ we generate gen_Data_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, -- The method bindings - LHsBinds RdrName) -- Auxiliary bindings -gen_Data_binds fix_env tycon + DerivAuxBinds) -- Auxiliary bindings +gen_Data_binds _ tycon = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind], -- Auxiliary definitions: the data type and constructors - datatype_bind `consBag` listToBag (map mk_con_bind data_cons)) + DerivAuxBind datatype_bind : map mk_con_bind data_cons) where tycon_loc = getSrcSpan tycon tycon_name = tyConName tycon @@ -1136,7 +1212,8 @@ gen_Data_binds fix_env tycon ------------ $cT1 etc mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc - mk_con_bind dc = mkVarBind + mk_con_bind dc = DerivAuxBind $ + mkVarBind tycon_loc (mk_constr_name dc) (nlHsApps mkConstr_RDR (constr_args dc)) @@ -1154,15 +1231,17 @@ gen_Data_binds fix_env tycon fixity | is_infix = infix_RDR | otherwise = prefix_RDR -gfoldl_RDR = varQual_RDR gENERICS FSLIT("gfoldl") -gunfold_RDR = varQual_RDR gENERICS FSLIT("gunfold") -toConstr_RDR = varQual_RDR gENERICS FSLIT("toConstr") -dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf") -mkConstr_RDR = varQual_RDR gENERICS FSLIT("mkConstr") -mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType") -conIndex_RDR = varQual_RDR gENERICS FSLIT("constrIndex") -prefix_RDR = dataQual_RDR gENERICS FSLIT("Prefix") -infix_RDR = dataQual_RDR gENERICS FSLIT("Infix") +gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, + mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR :: RdrName +gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") +gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") +toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") +dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf") +mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr") +mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType") +conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex") +prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix") +infix_RDR = dataQual_RDR gENERICS (fsLit "Infix") \end{code} %************************************************************************ @@ -1183,16 +1262,12 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) fiddling around. \begin{code} -data TagThingWanted - = GenCon2Tag | GenTag2Con | GenMaxTag +genAuxBind :: DerivAuxBind -> LHsBind RdrName -gen_tag_n_con_monobind - :: ( RdrName, -- (proto)Name for the thing in question - TyCon, -- tycon in question - TagThingWanted) - -> LHsBind RdrName +genAuxBind (DerivAuxBind bind) + = bind -gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) +genAuxBind (GenCon2Tag tycon) | lots_of_constructors = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)] @@ -1200,6 +1275,7 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon)) where + rdr_name = con2tag_RDR tycon tycon_loc = getSrcSpan tycon tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon) @@ -1226,19 +1302,21 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) mk_stuff con = ([nlWildConPat con], nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG)))) -gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con) +genAuxBind (GenTag2Con tycon) = mk_FunBind (getSrcSpan tycon) rdr_name [([nlConVarPat intDataCon_RDR [a_RDR]], noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr) (nlHsTyVar (getRdrName tycon))))] + where + rdr_name = tag2con_RDR tycon -gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag) +genAuxBind (GenMaxTag tycon) = mkVarBind (getSrcSpan tycon) rdr_name (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))) where + rdr_name = maxtag_RDR tycon max_tag = case (tyConDataCons tycon) of data_cons -> toInteger ((length data_cons) - fIRST_TAG) - \end{code} %************************************************************************ @@ -1262,6 +1340,7 @@ careful_compare_Case :: -- checks for primitive types... -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName +cmp_eq_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b -- Was: compare_gen_Case cmp_eq_RDR @@ -1277,9 +1356,10 @@ careful_compare_Case tycon ty eq a b | not (isUnLiftedType ty) = compare_gen_Case eq a b | otherwise -- We have to do something special for primitive things... - = nlHsIf (genOpApp a relevant_eq_op b) - eq - (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr) + = nlHsIf (genOpApp a relevant_lt_op b) -- Test (<) first, not (==), becuase the latter + ltTag_Expr -- is true less often, so putting it first would + -- mean more tests (dynamically) + (nlHsIf (genOpApp a relevant_eq_op b) eq gtTag_Expr) where relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty) relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty) @@ -1301,7 +1381,7 @@ assoc_ty_id :: String -- The class involved -> [(Type,a)] -- The table -> Type -- The type -> a -- The result of the lookup -assoc_ty_id cls_str tycon tbl ty +assoc_ty_id cls_str _ tbl ty | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+> text "for primitive type" <+> ppr ty) | otherwise = head res @@ -1328,6 +1408,7 @@ lt_op_tbl = ,(doublePrimTy, DoubleLtOp) ] +box_con_tbl :: [(Type, RdrName)] box_con_tbl = [(charPrimTy, getRdrName charDataCon) ,(intPrimTy, getRdrName intDataCon) @@ -1354,7 +1435,7 @@ eq_Expr tycon ty a b = genOpApp a eq_op b \begin{code} untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName -untag_Expr tycon [] expr = expr +untag_Expr _ [] expr = expr untag_Expr tycon ((untag_this, put_tag_here) : more) expr = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-} [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)] @@ -1393,15 +1474,18 @@ nested_compose_Expr (e: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 :: LHsExpr RdrName impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv")) -- illegal_Expr is used when signalling error conditions in the RHS of a derived -- method. It is currently only used by Enum.{succ,pred} +illegal_Expr :: String -> String -> String -> LHsExpr RdrName illegal_Expr meth tp msg = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg))) -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you -- to include the value of a_RDR in the error string. +illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName illegal_toEnum_tag tp maxtag = nlHsApp (nlHsVar error_RDR) (nlHsApp (nlHsApp (nlHsVar append_RDR) @@ -1419,31 +1503,38 @@ illegal_toEnum_tag tp maxtag = (nlHsVar maxtag)) (nlHsLit (mkHsString ")")))))) +parenify :: LHsExpr RdrName -> LHsExpr RdrName parenify e@(L _ (HsVar _)) = e parenify e = mkHsPar e -- genOpApp wraps brackets round the operator application, so that the -- renamer won't subsequently try to re-associate it. +genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2) \end{code} \begin{code} -a_RDR = mkVarUnqual FSLIT("a") -b_RDR = mkVarUnqual FSLIT("b") -c_RDR = mkVarUnqual FSLIT("c") -d_RDR = mkVarUnqual FSLIT("d") -k_RDR = mkVarUnqual FSLIT("k") -z_RDR = mkVarUnqual FSLIT("z") -ah_RDR = mkVarUnqual FSLIT("a#") -bh_RDR = mkVarUnqual FSLIT("b#") -ch_RDR = mkVarUnqual FSLIT("c#") -dh_RDR = mkVarUnqual FSLIT("d#") -cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq") - +a_RDR, b_RDR, c_RDR, d_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR, + cmp_eq_RDR :: RdrName +a_RDR = mkVarUnqual (fsLit "a") +b_RDR = mkVarUnqual (fsLit "b") +c_RDR = mkVarUnqual (fsLit "c") +d_RDR = mkVarUnqual (fsLit "d") +k_RDR = mkVarUnqual (fsLit "k") +z_RDR = mkVarUnqual (fsLit "z") +ah_RDR = mkVarUnqual (fsLit "a#") +bh_RDR = mkVarUnqual (fsLit "b#") +ch_RDR = mkVarUnqual (fsLit "c#") +dh_RDR = mkVarUnqual (fsLit "d#") +cmp_eq_RDR = mkVarUnqual (fsLit "cmp_eq") + +as_RDRs, bs_RDRs, cs_RDRs :: [RdrName] as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] +a_Expr, b_Expr, c_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, + false_Expr, true_Expr :: LHsExpr RdrName a_Expr = nlHsVar a_RDR b_Expr = nlHsVar b_RDR c_Expr = nlHsVar c_RDR @@ -1453,6 +1544,7 @@ gtTag_Expr = nlHsVar gtTag_RDR false_Expr = nlHsVar false_RDR true_Expr = nlHsVar true_RDR +a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat RdrName a_Pat = nlVarPat a_RDR b_Pat = nlVarPat b_RDR c_Pat = nlVarPat c_RDR @@ -1460,12 +1552,13 @@ d_Pat = nlVarPat d_RDR k_Pat = nlVarPat k_RDR z_Pat = nlVarPat z_RDR -con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName +con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName -- Generates Orig s RdrName, for the binding positions con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_" tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_" maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_" +mk_tc_deriv_name :: TyCon -> [Char] -> RdrName mk_tc_deriv_name tycon str = mkDerivedRdrName tc_name mk_occ where @@ -1479,8 +1572,11 @@ s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports PrelNames, so PrelNames can't import PrimOp. \begin{code} +primOpRdrName :: PrimOp -> RdrName primOpRdrName op = getRdrName (primOpId op) +minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, leInt_RDR, + tagToEnum_RDR :: RdrName minusInt_RDR = primOpRdrName IntSubOp eqInt_RDR = primOpRdrName IntEqOp ltInt_RDR = primOpRdrName IntLtOp @@ -1488,5 +1584,6 @@ geInt_RDR = primOpRdrName IntGeOp leInt_RDR = primOpRdrName IntLeOp tagToEnum_RDR = primOpRdrName TagToEnumOp +error_RDR :: RdrName error_RDR = getRdrName eRROR_ID \end{code}