X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Ftypecheck%2FTcGenDeriv.lhs;h=dcf230ab89dc5b4883f049515a5705191db3f4e7;hb=d95ce839533391e7118257537044f01cbb1d6694;hp=a7956e4fcc7fb4e4cc9aeeb88bf9381ef9a4c990;hpb=8c2fd74094dc533bf3256158325e3f091e57e5d2;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index a7956e4..dcf230a 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -12,7 +12,7 @@ This is where we do all the grimy bindings' generation. \begin{code} module TcGenDeriv ( - DerivAuxBind(..), DerivAuxBinds, isDupAux, + DerivAuxBinds, isDupAux, gen_Bounded_binds, gen_Enum_binds, @@ -57,15 +57,21 @@ import Data.List ( partition, intersperse ) type DerivAuxBinds = [DerivAuxBind] data DerivAuxBind -- Please add these auxiliary top-level bindings - = DerivAuxBind (LHsBind RdrName) - | GenCon2Tag TyCon -- The con2Tag for given TyCon + = GenCon2Tag TyCon -- The con2Tag for given TyCon | GenTag2Con TyCon -- ...ditto tag2Con | GenMaxTag TyCon -- ...and maxTag + -- Scrap your boilerplate + | MkDataCon DataCon -- For constructor C we get $cC :: Constr + | MkTyCon TyCon -- For tycon T we get $tT :: DataType + + 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 (MkDataCon dc1) (MkDataCon dc2) = dc1 == dc2 +isDupAux (MkTyCon tc1) (MkTyCon tc2) = tc1 == tc2 isDupAux _ _ = False \end{code} @@ -552,8 +558,8 @@ gen_Bounded_binds loc tycon data_cons = tyConDataCons tycon ----- enum-flavored: --------------------------- - min_bound_enum = mkVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) - max_bound_enum = mkVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) + min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) + max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) data_con_1 = head data_cons data_con_N = last data_cons @@ -563,9 +569,9 @@ gen_Bounded_binds loc tycon ----- single-constructor-flavored: ------------- arity = dataConSourceArity data_con_1 - min_bound_1con = mkVarBind loc minBound_RDR $ + min_bound_1con = mkHsVarBind loc minBound_RDR $ nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR) - max_bound_1con = mkVarBind loc maxBound_RDR $ + max_bound_1con = mkHsVarBind loc maxBound_RDR $ nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR) \end{code} @@ -682,9 +688,7 @@ gen_Ix_binds loc tycon data_con = case tyConSingleDataCon_maybe tycon of -- just checking... Nothing -> panic "get_Ix_binds" - Just dc | any isUnLiftedType (dataConOrigArgTys dc) - -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon) - | otherwise -> dc + Just dc -> dc con_arity = dataConSourceArity data_con data_con_RDR = getRdrName data_con @@ -797,16 +801,16 @@ gen_Read_binds get_fixity loc tycon where ----------------------------------------------------------------------- default_readlist - = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR) + = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR) default_readlistprec - = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) + = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) ----------------------------------------------------------------------- data_cons = tyConDataCons tycon (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons - read_prec = mkVarBind loc readPrec_RDR + read_prec = mkHsVarBind loc readPrec_RDR (nlHsApp (nlHsVar parens_RDR) read_cons) read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons) @@ -837,22 +841,26 @@ gen_Read_binds get_fixity loc tycon con_str = data_con_str data_con prefix_parser = mk_parser prefix_prec prefix_stmts body - prefix_stmts -- T a b c - = (if not (isSym con_str) then - [bindLex (ident_pat con_str)] - else [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"]) - ++ read_args + + read_prefix_con + | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"] + | otherwise = [bindLex (ident_pat con_str)] + read_infix_con + | isSym con_str = [bindLex (symbol_pat con_str)] + | otherwise = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"] + + prefix_stmts -- T a b c + = read_prefix_con ++ read_args + infix_stmts -- a %% b, or a `T` b = [read_a1] - ++ (if isSym con_str - then [bindLex (symbol_pat con_str)] - else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]) + ++ read_infix_con ++ [read_a2] record_stmts -- T { f1 = a, f2 = b } - = [bindLex (ident_pat (wrapOpParens con_str)), - read_punc "{"] + = read_prefix_con + ++ [read_punc "{"] ++ concat (intersperse [read_punc ","] field_stmts) ++ [read_punc "}"] @@ -888,9 +896,8 @@ gen_Read_binds get_fixity loc tycon data_con_str con = occNameString (getOccName con) read_punc c = bindLex (punc_pat c) - read_arg a ty - | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty) - | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])) + read_arg a ty = ASSERT( not (isUnLiftedType ty) ) + noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])) read_field lbl a = read_lbl lbl ++ [read_punc "=", @@ -948,7 +955,7 @@ gen_Show_binds get_fixity loc tycon = (listToBag [shows_prec, show_list], []) where ----------------------------------------------------------------------- - show_list = mkVarBind loc showList_RDR + show_list = mkHsVarBind loc showList_RDR (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0)))) ----------------------------------------------------------------------- shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon)) @@ -1132,9 +1139,8 @@ gen_Data_binds :: SrcSpan gen_Data_binds loc tycon = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind], -- Auxiliary definitions: the data type and constructors - DerivAuxBind datatype_bind : map mk_con_bind data_cons) + MkTyCon tycon : map MkDataCon data_cons) where - tycon_name = tyConName tycon data_cons = tyConDataCons tycon n_cons = length data_cons one_constr = n_cons == 1 @@ -1181,40 +1187,7 @@ gen_Data_binds loc tycon loc dataTypeOf_RDR [nlWildPat] - (nlHsVar data_type_name) - - ------------ $dT - data_type_name = mkAuxBinderName tycon_name mkDataTOcc - datatype_bind = mkVarBind - loc - data_type_name - ( nlHsVar mkDataType_RDR - `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon))) - `nlHsApp` nlList constrs - ) - constrs = [nlHsVar (mk_constr_name con) | con <- data_cons] - - - ------------ $cT1 etc - mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc - mk_con_bind dc = DerivAuxBind $ - mkVarBind - loc - (mk_constr_name dc) - (nlHsApps mkConstr_RDR (constr_args dc)) - constr_args dc = - [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag - nlHsVar data_type_name, -- DataType - nlHsLit (mkHsString (occNameString dc_occ)), -- String name - nlList labels, -- Field labels - nlHsVar fixity] -- Fixity - where - labels = map (nlHsLit . mkHsString . getOccString) - (dataConFieldLabels dc) - dc_occ = getOccName dc - is_infix = isDataSymOcc dc_occ - fixity | is_infix = infix_RDR - | otherwise = prefix_RDR + (nlHsVar (mk_data_type_name tycon)) gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR :: RdrName @@ -1248,10 +1221,6 @@ fiddling around. \begin{code} genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName - -genAuxBind _loc (DerivAuxBind bind) - = bind - genAuxBind loc (GenCon2Tag tycon) | lots_of_constructors = mk_FunBind loc rdr_name [([], get_tag_rhs)] @@ -1295,12 +1264,44 @@ genAuxBind loc (GenTag2Con tycon) rdr_name = tag2con_RDR tycon genAuxBind loc (GenMaxTag tycon) - = mkVarBind loc rdr_name + = mkHsVarBind loc 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) + +genAuxBind loc (MkTyCon tycon) -- $dT + = mkHsVarBind loc (mk_data_type_name tycon) + ( nlHsVar mkDataType_RDR + `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon))) + `nlHsApp` nlList constrs ) + where + constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon] + +genAuxBind loc (MkDataCon dc) -- $cT1 etc + = mkHsVarBind loc (mk_constr_name dc) + (nlHsApps mkConstr_RDR constr_args) + where + constr_args + = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag + nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType + nlHsLit (mkHsString (occNameString dc_occ)), -- String name + nlList labels, -- Field labels + nlHsVar fixity] -- Fixity + + labels = map (nlHsLit . mkHsString . getOccString) + (dataConFieldLabels dc) + dc_occ = getOccName dc + is_infix = isDataSymOcc dc_occ + fixity | is_infix = infix_RDR + | otherwise = prefix_RDR + +mk_data_type_name :: TyCon -> RdrName -- "$tT" +mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc + +mk_constr_name :: DataCon -> RdrName -- "$cC" +mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc \end{code} %************************************************************************