X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Ftypecheck%2FTcGenDeriv.lhs;h=9826f2f88193363eb28392e333bd3d399dd03dc8;hb=e79c9ce01d0ce4412bd4bcd99c8c728a6a2ec569;hp=1a0043ad03f2ed616ec40610ea44e3bc16b269df;hpb=9319fbaf14f420cbbd9e670093cc86c5f04b7800;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 1a0043a..9826f2f 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} @@ -156,7 +162,7 @@ gen_Eq_binds loc tycon no_nullary_cons = null nullary_cons rest | no_nullary_cons - = case maybeTyConSingleCon tycon of + = case tyConSingleDataCon_maybe tycon of Just _ -> [] Nothing -> -- if cons don't match, then False [([nlWildPat, nlWildPat], false_Expr)] @@ -680,11 +686,9 @@ gen_Ix_binds loc tycon = listToBag [single_con_range, single_con_index, single_con_inRange] data_con - = case maybeTyConSingleCon tycon of -- just checking... + = 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 @@ -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 "=", @@ -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,8 @@ 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 +1222,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)] @@ -1301,6 +1271,38 @@ genAuxBind loc (GenMaxTag tycon) rdr_name = maxtag_RDR tycon max_tag = case (tyConDataCons tycon) of data_cons -> toInteger ((length data_cons) - fIRST_TAG) + +genAuxBind loc (MkTyCon tycon) -- $dT + = mkVarBind 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 + = mkVarBind 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} %************************************************************************