Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Source file ppx_enumerate.ml
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290openBaseopenPpxlibopenAst_builder.Defaultletname_of_type_name=function|"t"->"all"|type_name->"all_of_"^type_nameletname_of_type_variablestr="_"^name_of_type_namestr(* Utility functions *)letenumeration_type_of_tdtd=letinit=lettp=core_type_of_type_declarationtdinletloc=tp.ptyp_locin[%type:[%ttp]list]inList.fold_righttd.ptype_params~init~f:(fun(tp,_variance)acc->letloc=tp.ptyp_locin[%type:[%ttp]list->[%tacc]]);;letsig_of_tdtd=lettd=name_type_params_in_tdtdinletenumeration_type=enumeration_type_of_tdtdinletname=name_of_type_nametd.ptype_name.txtinletloc=td.ptype_locinpsig_value~loc(value_description~loc~name:(Located.mk~locname)~type_:enumeration_type~prim:[])letsig_of_tds~loc~path:_(_rec_flag,tds)=letsg_name="Ppx_enumerate_lib.Enumerable.S"inmatchmk_named_sigtds~loc~sg_name~handle_polymorphic_variant:truewith|Someinclude_infos->[psig_include~locinclude_infos]|None->List.maptds~f:sig_of_tdletgen_symbol=gen_symbol~prefix:"enumerate"lettuplelocexprs=assert(List.lengthexprs>=2);pexp_tuple~locexprsletpatt_tuplelocpats=assert(List.lengthpats>=2);ppat_tuple~locpatsletapplyeel=eapply~loc:e.pexp_loceelletreplace_variables_by_underscores=letmap=objectinheritAst_traverse.mapassupermethod!core_type_descty=matchsuper#core_type_desctywith|Ptyp_var_->Ptyp_any|ty->tyendinmap#core_type;;letlist_maplocl~f=letelement=gen_symbol()inletapplied=f(evar~locelement)in[%exprletrecmaplacc=matchlwith|[]->Ppx_enumerate_lib.List.revacc|[%ppvar~locelement]::l->mapl([%eapplied]::acc)inmap[%el][]](* [cartesian_product_map l's f loc] takes a list of expressions of type list, and
returns code generating the Cartesian product of those lists, with [f] applied to each
tuple.
*)letcartesian_product_map~exhaust_checkl's~floc=matchl'swith|[]->Location.raise_errorf~loc"cartesian_product_map passed list of zero length"|[l]->list_maplocl~f:(funx->f[x])|_->letlidx=evar~locxinletpatt_lidx=pvar~locxinletalias_vars=List.mapl's~f:(fun_->gen_symbol())inletinit=letlen=List.lengthl'sinlethd_vars=List.mapl's~f:(fun_->gen_symbol())inletargs_vars=List.mapl's~f:(fun_->gen_symbol())inlettl_var=gen_symbol()inletbase_case=letpatts=List.rev([%pat?[]]::List.init(len-1)~f:(fun_->[%pat?_]))incase~guard:None~lhs:(patt_tuplelocpatts)~rhs:[%exprPpx_enumerate_lib.List.revacc]inletapply_case=letpatts=List.mapihd_vars~f:(funix->[%pat?([%ppvar~locx]::[%pifi=0thenpatt_lidtl_varelseppat_any~loc])])incase~guard:None~lhs:(patt_tuplelocpatts)~rhs:(apply[%exprloop([%ef(List.maphd_vars~f:lid)]::acc)](evar~loctl_var::List.map(List.tl_exnargs_vars)~f:lid))inletdecrement_cases=List.init(len-1)~f:(funi->letpatts=List.initi~f:(fun_->ppat_any~loc)@[[%pat?[]];[%pat?(_::[%ppvar~loctl_var])]]@List.init(len-i-2)~f:(fun_->ppat_any~loc)incase~guard:None~lhs:(patt_tuplelocpatts)~rhs:(apply[%exprloopacc](List.map~f:lid(List.takealias_vars(i+1))@evar~loctl_var::(List.map~f:lid(List.dropargs_vars(i+2))))))inletdecrement_cases=ifexhaust_checkthendecrement_caseselsedecrement_cases@[case~guard:None~lhs:(ppat_any~loc)~rhs:[%exprassertfalse]]inletmatch_exp=pexp_match~loc(tupleloc(List.mapargs_vars~f:lid))(base_case::apply_case::decrement_cases)inletmatch_exp=ifexhaust_checkthenmatch_expelseletloc=Location.nonein{match_expwithpexp_attributes=[attribute~loc~name:(Location.{txt="ocaml.warning";loc})~payload:(PStr[pstr_eval~loc(estring~loc"-11")[]])]}in[%exprletrecloopacc=[%eeabstract~loc(List.mapargs_vars~f:patt_lid)match_exp]in[%eapply[%exprloop[]](List.map~f:lidalias_vars)]]inStdlib.ListLabels.fold_right2alias_varsl's~init~f:(funalias_varinput_listacc->[%exprlet[%ppvar~localias_var]=[%einput_list]in[%eacc]])(* Here we do two things: simplify append on static lists, to make the generated code more
readable and rewrite (List.append (List.append a b) c) as (List.append a (List.append b
c)), to avoid a quadratic behaviour with long nesting to the left. *)letreclist_appendlocl1l2=matchl2with|[%expr[]]->l1|_->matchl1with|[%expr[]]->l2|[%expr[%e?hd]::[%e?tl]]->[%expr[%ehd]::[%elist_appendloctll2]]|[%exprPpx_enumerate_lib.List.append[%e?ll][%e?lr]]->list_appendlocll(list_appendloclrl2)|_->[%exprPpx_enumerate_lib.List.append[%el1][%el2]]letrecenum~exhaust_check~main_typety=letloc={ty.ptyp_locwithloc_ghost=true}inmatchty.ptyp_descwith|Ptyp_constr({txt=Lident"bool";_},[])->[%expr[false;true]]|Ptyp_constr({txt=Lident"unit";_},[])->[%expr[()]]|Ptyp_constr({txt=Lident"option";_},[tp])->[%expr(None::[%elist_maploc(enum~exhaust_check~main_type:tptp)~f:(fune->[%exprSome[%ee]])])]|Ptyp_constr(id,args)->type_constr_conv~locid~f:name_of_type_name(List.mapargs~f:(funt->enum~exhaust_checkt~main_type:t))|Ptyp_tupletps->product~exhaust_checkloctps(funexprs->tuplelocexprs)|Ptyp_variant(row_fields,Closed,None)->List.fold_leftrow_fields~init:[%expr[]]~f:(funaccrf->list_appendlocacc(variant_case~exhaust_checklocrf~main_type))|Ptyp_varid->evar~loc(name_of_type_variableid)|_->Location.raise_errorf~loc"ppx_enumerate: unsupported type"andvariant_case~exhaust_checklocrow_field~main_type=matchrow_field.prf_descwith|Rtag({txt=cnstr;_},true,_)|Rtag({txt=cnstr;_},_,[])->[%expr[[%epexp_variant~loccnstrNone]]]|Rtag({txt=cnstr;_},false,tp::_)->list_maploc(enum~exhaust_checktp~main_type:tp)~f:(fune->pexp_variant~loccnstr(Somee))|Rinheritty->lete=enum~exhaust_check~main_typetyin[%expr([%ee]:>[%treplace_variables_by_underscoresmain_type]list)]andconstructor_case~exhaust_checkloccd=matchcd.pcd_argswith|Pcstr_tuple[]->[%expr[[%eeconstructcdNone]]]|Pcstr_tupletps->product~exhaust_checkloctps(funx->econstructcd(Some(pexp_tuple~locx)))|Pcstr_recordlds->enum_of_lab_decs~exhaust_check~loclds~k:(funx->econstructcd(Somex))andenum_of_lab_decs~exhaust_check~loclds~k=letfield_names,types=List.unzip(List.maplds~f:(funld->(ld.pld_name,ld.pld_type)))inproduct~exhaust_checkloctypes(functionl->letfields=List.map2_exnfield_namesl~f:(funfield_namex->(Located.maplidentfield_name,x))ink(pexp_record~locfieldsNone))andproduct~exhaust_checkloctpsf=letall=List.maptps~f:(funtp->enum~exhaust_check~main_type:tptp)incartesian_product_map~exhaust_checkallloc~fletquantifyloctpstyp=matchtpswith|[]->typ|_->ptyp_poly~loc(List.maptps~f:(funx->(get_type_param_namex)))typletenum_of_td~exhaust_checktd=lettd=name_type_params_in_tdtdinletloc=td.ptype_locinletall=letmain_type=ptyp_constr~loc(Located.maplidenttd.ptype_name)(List.maptd.ptype_params~f:(fun_->ptyp_any~loc))inmatchtd.ptype_kindwith|Ptype_variantcds->(* Process [cd] elements in same order as camlp4 to avoid code-gen diffs caused by
different order of [gen_symbol] calls *)List.fold_leftcds~init:[%expr[]]~f:(funacccd->list_appendlocacc(constructor_case~exhaust_checkloccd))|Ptype_recordlds->enum_of_lab_decs~exhaust_check~loclds~k:(funx->x)|Ptype_open->Location.raise_errorf~loc"ppx_enumerate: open types not supported"|Ptype_abstract->matchtd.ptype_manifestwith|None->[%expr[]]|Sometp->enum~exhaust_checktp~main_typeinletname=name_of_type_nametd.ptype_name.txtinletargs=List.maptd.ptype_params~f:(fun((tp,_)asx)->letname=name_of_type_variable(get_type_param_namex).txtinletloc=tp.ptyp_locinpvar~locname)inletenumeration_type=lettyp=enumeration_type_of_tdtdinquantifyloctd.ptype_paramstypinletbody=eabstract~locargsallinletzero_args=(List.lengthargs=0)inifzero_args(* constrain body rather than pattern *)then[%strlet[%ppvar~locname]=([%ebody]:[%tenumeration_type])]else[%strlet[%ppvar~locname]:[%tenumeration_type]=[%ebody]]letenumerate=letstr_args=Deriving.Args.(empty+>flag"no_exhaustiveness_check")inDeriving.add"enumerate"~str_type_decl:(Deriving.Generator.makestr_args(fun~loc~path:_(_rec,tds)no_exhaustiveness_check->matchtdswith|[td]->enum_of_td~exhaust_check:(notno_exhaustiveness_check)td|_->Location.raise_errorf~loc"only one type at a time is support by ppx_enumerate"))~sig_type_decl:(Deriving.Generator.makeDeriving.Args.emptysig_of_tds)let()=Deriving.add"all"~extension:(fun~loc:_~path:_ty->enum~exhaust_check:truety~main_type:ty)|>Deriving.ignore