Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Source file bin_shape_expand.ml
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337openBaseopenPpxlibopenAst_builder.Defaultletraise_errorf~locfmt=Location.raise_errorf~loc(Caml.(^^)"ppx_bin_shape: "fmt)letloc_stringloc=[%exprBin_prot.Shape.Location.of_string[%ePpx_here_expander.lift_position_as_string~loc]]letapp_list~loc(func:expression)(args:expressionlist)=[%expr[%efunc][%eelist~locargs]]letcurry_app_list~loc(func:expression)(args:expressionlist)=List.fold_leftargs~init:func~f:(funaccarg->[%expr[%eacc][%earg]])letbin_shape_tname="bin_shape_"^tnameletbin_shape_lid~locid=unapplied_type_constr_conv~locid~f:bin_shape_letshape_tid~loc~(tname:string)=[%exprBin_prot.Shape.Tid.of_string[%eestring~loctname]]letshape_vid~loc~(tvar:string)=[%exprBin_prot.Shape.Vid.of_string[%eestring~loctvar]]letshape_rec_app~loc~(tname:string)=[%exprBin_prot.Shape.rec_app[%eshape_tid~loc~tname]]letshape_top_app~loc~(tname:string)=[%exprBin_prot.Shape.top_app_group[%eshape_tid~loc~tname]]letshape_tuple~loc(exps:expressionlist)=[%exprBin_prot.Shape.tuple[%eelist~locexps]]letshape_record~loc(xs:(string*expression)list)=[%exprBin_prot.Shape.record[%eelist~loc(List.mapxs~f:(fun(s,e)->[%expr([%eestring~locs],[%ee])]))]]letshape_variant~loc(xs:(string*expressionlist)list)=[%exprBin_prot.Shape.variant[%eelist~loc(List.mapxs~f:(fun(s,es)->[%expr([%eestring~locs],[%eelist~loces])]))]]letshape_poly_variant~loc(xs:expressionlist)=[%exprBin_prot.Shape.poly_variant[%eloc_stringloc][%eelist~locxs]]typestring_literal_or_other_expression=|String_literalofstring|Other_expressionofexpressionletstring_literalfs=f(String_literals)letother_expressionfe=f(Other_expressione)letshape_annotate~loc~name(x:expression)=letname=matchnamewith|Other_expressione->e|String_literals->[%exprBin_prot.Shape.Uuid.of_string[%eestring~locs]]in[%exprBin_prot.Shape.annotate[%ename][%ex]]letshape_basetype~loc~uuid(xs:expressionlist)=letuuid=matchuuidwith|Other_expressione->e|String_literals->[%exprBin_prot.Shape.Uuid.of_string[%eestring~locs]]inapp_list~loc[%exprBin_prot.Shape.basetype[%euuid]]xsmoduleContext:sigtypetvalcreate:type_declarationlist->tvalis_local:t->tname:string->bool(* which names are defined in the local group *)end=structtypet={tds:type_declarationlist}letcreatetds={tds}letis_localt~tname=List.existst.tds~f:(funtd->String.equaltnametd.ptype_name.txt)endletof_type:(allow_free_vars:bool->context:Context.t->core_type->expression)=fun~allow_free_vars~context->letrectraverse_row~loc~typ_for_error(row:row_field):expression=matchrow.prf_descwith|Rtag(_,true,_::_)|Rtag(_,false,_::_::_)->raise_errorf~loc"unsupported '&' in row_field: %s"(string_of_core_typetyp_for_error)|Rtag({txt;_},true,[])->[%exprBin_prot.Shape.constr[%eestring~loctxt]None]|Rtag({txt;_},false,[t])->[%exprBin_prot.Shape.constr[%eestring~loctxt](Some[%etraverset])]|Rtag(_,false,[])->raise_errorf~loc"impossible row_type: Rtag (_,_,false,[])"|Rinheritt->[%exprBin_prot.Shape.inherit_[%eloc_stringt.ptyp_loc][%etraverset]]andtraversetyp=letloc=typ.ptyp_locinmatchtyp.ptyp_descwith|Ptyp_constr(lid,typs)->letargs=List.maptyps~f:traverseinbeginmatchmatchlid.txtwith|Lidenttname->ifContext.is_localcontext~tnamethenSometnameelseNone|_->Nonewith|Sometname->app_list~loc(shape_rec_app~loc~tname)args|None->curry_app_list~loc(bin_shape_lid~loclid)argsend|Ptyp_tupletyps->shape_tuple~loc(List.maptyps~f:traverse)|Ptyp_vartvar->ifallow_free_varsthen[%exprBin_prot.Shape.var[%eloc_stringloc][%eshape_vid~loc~tvar]]elseraise_errorf~loc"unexpected free type variable: '%s"tvar|Ptyp_variant(rows,_,None)->shape_poly_variant~loc(List.maprows~f:(funrow->traverse_row~loc~typ_for_error:typrow))|Ptyp_poly(_,_)|Ptyp_variant(_,_,Some_)|Ptyp_any|Ptyp_arrow_|Ptyp_object_|Ptyp_class_|Ptyp_alias_|Ptyp_package_|Ptyp_extension_->raise_errorf~loc"unsupported type: %s"(string_of_core_typetyp)intraverselettvars_of_def(td:type_declaration):stringlist=List.maptd.ptype_params~f:(fun(typ,_variance)->letloc=typ.ptyp_locinmatchtypwith|{ptyp_desc=Ptyp_vartvar;_}->tvar|_->raise_errorf~loc"unexpected non-tvar in type params")moduleStructure:sigvalgen:(structure,rec_flag*type_declarationlist)Deriving.Generator.tend=structletof_type=of_type~allow_free_vars:trueletof_label_decs~loc~contextlds=shape_record~loc(List.maplds~f:(funld->(ld.pld_name.txt,of_type~contextld.pld_type)))letof_kind~loc~context(k:type_kind):expressionoption=matchkwith|Ptype_recordlds->Some(of_label_decs~loc~contextlds)|Ptype_variantcds->Some(shape_variant~loc(List.mapcds~f:(funcd->(cd.pcd_name.txt,beginmatchcd.pcd_argswith|Pcstr_tupleargs->List.mapargs~f:(of_type~context)|Pcstr_recordlds->[of_label_decs~loc~contextlds]end))))|Ptype_abstract->None|Ptype_open->raise_errorf~loc"open types not supported"letexpr_of_td~loc~context(td:type_declaration):expressionoption=letexpr=matchof_kind~loc~contexttd.ptype_kindwith|Somee->Somee|None->(* abstract type *)matchtd.ptype_manifestwith|None->(* A fully abstract type is usually intended to represent an empty type
(0-constructor variant). *)Some(shape_variant~loc[])|Somemanifest->Some(of_type~contextmanifest)inexprletgen=Deriving.Generator.makeDeriving.Args.(empty+>arg"annotate"((map~f:string_literal(estring__))|||(map~f:other_expression__))+>arg"annotate_provisionally"((map~f:string_literal(estring__))|||(map~f:other_expression__))+>arg"basetype"((map~f:string_literal(estring__))|||(map~f:other_expression__)))(fun~loc~path:_(rec_flag,tds)annotation_optannotation_provisionally_optbasetype_opt->lettds=List.maptds~f:name_type_params_in_tdinletcontext=matchrec_flagwith|Recursive->Context.createtds|Nonrecursive->Context.create[]inletmk_patmk_=letpats=List.maptds~f:(funtd->let{Location.loc;txt=tname}=td.ptype_nameinletname=mk_tnameinppat_var~loc(Loc.makename~loc))inppat_tuple~locpatsinlet()=matchannotation_provisionally_optwith|Some_->raise_errorf~loc"[~annotate_provisionally] was renamed to [~annotate]. \
Please use that."|None->()inlet()=matchannotation_opt,basetype_optwith|Some_,Some_->raise_errorf~loc"cannot write both [bin_shape ~annotate] and [bin_shape ~basetype]"|_->()inlet()=matchtds,annotation_optwith|([]|_::_::_),Some_->raise_errorf~loc"unexpected [~annotate] on multi type-declaration"|_->()inlet()=matchtds,basetype_optwith|([]|_::_::_),Some_->raise_errorf~loc"unexpected [~basetype] on multi type-declaration"|_->()inletannotate_f:(expression->expression)=matchannotation_optwith|None->(fune->e)|Somename->shape_annotate~loc~nameinlettagged_schemes=List.filter_maptds~f:(funtd->let{Location.loc;txt=tname}=td.ptype_nameinletbody_opt=expr_of_td~loc~contexttdinmatchbody_optwith|None->None|Somebody->lettvars=tvars_of_deftdinletformals=List.maptvars~f:(funtvar->shape_vid~loc~tvar)in[%expr([%eshape_tid~loc~tname],[%eelist~locformals],[%ebody])]|>funx->Somex)inletmk_exprsmk_init=letexprs=List.maptds~f:(funtd->let{Location.loc;txt=tname}=td.ptype_nameinlettvars=tvars_of_deftdinletargs=List.maptvars~f:(funtvar->evar~loctvar)inList.fold_righttvars~init:(mk_init~tname~args)~f:(funtvaracc->[%exprfun[%ppvar~loctvar]->[%eacc]]))in[%expr[%epexp_tuple~locexprs]]inletexpr=matchbasetype_optwith|Someuuid->mk_exprs(fun~tname:_~args->shape_basetype~loc~uuidargs)|None->[%exprlet_group=Bin_prot.Shape.group[%eloc_stringloc][%eelist~loctagged_schemes]in[%emk_exprs(fun~tname~args->annotate_f(app_list~loc(shape_top_app~loc~tname)args))]]inletbindings=[value_binding~loc~pat:(mk_patbin_shape_)~expr]inletstructure=[pstr_value~locNonrecursivebindings;]instructure)endmoduleSignature:sigvalgen:(signature,rec_flag*type_declarationlist)Deriving.Generator.tend=structletof_tdtd:signature_item=lettd=name_type_params_in_tdtdinlet{Location.loc;txt=tname}=td.ptype_nameinletname=bin_shape_tnameinlettvars=tvars_of_deftdinlettype_=List.fold_lefttvars~init:[%type:Bin_prot.Shape.t]~f:(funacc_->[%type:Bin_prot.Shape.t->[%tacc]])inpsig_value~loc(value_description~loc~name:(Loc.makename~loc)~type_~prim:[])letgen=Deriving.Generator.makeDeriving.Args.empty(fun~loc:_~path:_(_rec_flag,tds)->List.maptds~f:of_td)endletstr_gen=Structure.genletsig_gen=Signature.genletshape_extension~loc:_typ=letcontext=Context.create[]inletallow_free_vars=falseinof_type~allow_free_vars~contexttypletdigest_extension~loctyp=[%exprBin_prot.Shape.Digest.to_hex(Bin_prot.Shape.eval_to_digest[%eshape_extension~loctyp])]