Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Source file coder.ml
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162openTypesopenErroropenResultopenOpenopenInternalmoduleMake(A:Min)=structincludeAexceptionExceptionoftargetError.ttype'aencoder=('a,target)Encoder.ttype'adecoder=('a,target)Decoder.ttype'adecoder_exn=('a,target)Decoder.t_exnletdecoder_of_deconstrf=fun?(trace=([]:targetError.trace))t->tryOk(ft)withexn->Error(`Exceptionexn,t,trace)letdecoder_exn_of_deconstrf=fun?(trace=([]:targetError.trace))t->tryftwithexn->raise(Exception(`Exceptionexn,t,trace))moduleDeconstrDecoder=structlettuple?trace=decoder_of_deconstrDeconstr.tuple?traceletvarianttyname?trace=decoder_of_deconstr(Deconstr.varianttyname)?traceletpoly_varianttyname?trace=decoder_of_deconstr(Deconstr.poly_varianttyname)?traceletrecordtyname?trace=decoder_of_deconstr(Deconstr.recordtyname)?traceletobject_tyname?trace=decoder_of_deconstr(Deconstr.object_tyname)?tracelettuple_exn?trace=decoder_exn_of_deconstrDeconstr.tuple?traceletvariant_exntyname?trace=decoder_exn_of_deconstr(Deconstr.varianttyname)?traceletpoly_variant_exntyname?trace=decoder_exn_of_deconstr(Deconstr.poly_varianttyname)?traceletrecord_exntyname?trace=decoder_exn_of_deconstr(Deconstr.recordtyname)?traceletobject_exntyname?trace=decoder_exn_of_deconstr(Deconstr.object_tyname)?traceendletexnf?tracev=matchf?tracevwith|Okv->v|Errore->raise(Exceptione)letthrowe=raise(Exceptione)letcatchfv=tryOk(fv)withExceptione->Erroreletresultf?tracet=tryOk(f?tracet)with|Exceptione->Errore|exn->Error(`Exceptionexn,t,~?trace)letfrom_Ok=function|Okv->v|Errore->raise(Exceptione)letformat_errorppf(desc,_,_)=Error.format_descppfdescletformat_full_error=Error.formatA.formatletformat_withencoderppft=formatppf(encodert)moduleHelper=struct(** {6 Useful tool functions for writing encoders+decoders of primitive types } *)(* This is not really target dependent, but included here for easier access *)letinteger_of_floatminmaxconvn=iffloorn<>nthenError"not an integer"elseifmin<=n&&n<=maxthenOk(convn)elseError"overflow"letlist_of(typetarget)gets(d:(_,target)Decoder.t)?(trace=[])v=matchgetsvwith|None->primitive_decoding_failure"Meta_conv.Internal.generic_list_of: listable expected"~tracev|Somexs->lettrace=`Nodev::traceinletmoduleE=LocalException(structtypet=targetend)inE.catchbeginfun()->list_mapi(funposx->E.exn(d~trace:(`Pospos::trace))x)xsend()letarray_ofgetsd?tracev=fmapArray.of_list(list_ofgetsd?tracev)letoption_ofextractf?tracev=matchextractvwith|SomeNone->OkNone|Some(Somev)->f?tracev>>=funx->Ok(Somex)|None->primitive_decoding_failure"Meta_conv.Internal.option_of: option expected"?tracevletref_ofextractf?tracev=matchextractvwith|Somev->f?tracev>>=funx->Ok{contents=x}|None->primitive_decoding_failure"Meta_conv.Internal.ref_of: option expected"?tracevletlazy_t_of(errorf:'targetError.t->'exn)f?trace:_v=Ok(lazy((* trace is reset to avoid leak *)matchf?trace:Nonevwith|Okv->v|Errore->errorfe))letof_mc_lazy_te=funv->matchLazy.forcevwith|Oka->ea|Error(_,a,_)->aletmc_lazy_t_off?trace:_v=Ok(lazy(f?trace:Nonev))(* trace is reset, to avoid leak *)letmc_fields_ofget_fieldsf?(trace=[])target=letopenResultinmatchget_fieldstargetwith|None->primitive_decoding_failure"mc_fields expected"~tracetarget|Somefields->lettrace=`Nodetarget::traceinmap(fun(name,target)->f?trace:(Some(`Fieldname::trace))target>>=funhost->Ok(name,host))fieldsletof_deconstrf=fun?(trace=[])v->tryOk(fv)with|Failuremes->Error(`Primitive_decoding_failuremes,v,trace)(** Hashtbl coders via list *)letof_hashtblof_listof_aof_btbl=of_list(funx->x)(Hashtbl.fold(funkvst->Constr.tuple[of_ak;of_bv]::st)tbl[])lethashtbl_oflist_ofa_ofb_of=fun?tracev->letab_of?(trace=[])v=DeconstrDecoder.tuple~tracev>>=function|[a;b]->a_of?trace:(Some(`Pos0::`Nodev::trace))a>>=funa->b_of?trace:(Some(`Pos0::`Nodev::trace))b>>=funb->Ok(a,b)|xs->Error(`Wrong_arity(2,List.lengthxs,None),v,trace)inlist_ofab_of?tracev>>=funabs->lettbl=Hashtbl.create101in(* CR jfuruse: size fixed *)List.iter(fun(k,v)->Hashtbl.addtblkv)abs;Oktblletof_resultembed_okembed_errorof_okof_error=function|Oke->embed_ok@@of_oke|Errore->embed_error@@of_erroreletresult_ofdividerok_oferror_of?tracev=divider?tracev>>=function|(Okv)->ok_of?tracev>>=funx->Ok(Okx)|(Errorv)->error_of?tracev>>=funx->Ok(Errorx)endend