Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Source file ui_effect.ml
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252open!CoreincludeUi_effect_intftype'at=..type'at+=Ignore:unitt|Many:unittlist->unitt(* We use this table for dispatching to the appropriate handler in an efficient way. *)typehidden=T:('at*('a->unit))->hiddenlethandlers:(hidden->unit)Hashtbl.M(Int).t=Hashtbl.create(moduleInt)~size:8moduleObj=structmoduleExtension_constructor=struct[@@@ocaml.warning"-3"]letid=Caml.Obj.extension_idletof_val=Caml.Obj.extension_constructorendendmoduleDefine(Handler:Handler):Swithtypeaction:=Handler.Action.tandtype'at:='at=structtype_t+=C:Handler.Action.t->unittletkey=Obj.Extension_constructor.id[%extension_constructorC]let()=Hashtbl.add_exnhandlers~key~data:(funinp->matchinpwith|T(Cvalue,callback)->Handler.handlevalue;callback()|_->raise_s[%message"Unrecognized variant"]);;letinjectv=CvendmoduleDefine1(Handler:Handler1):S1withtype'aaction:='aHandler.Action.tandtype'at:='at=structtype_t+=C:'aHandler.Action.t->'atletkey=Obj.Extension_constructor.id[%extension_constructorC]let()=Hashtbl.add_exnhandlers~key~data:(funinp->matchinpwith|T(Cvalue,callback)->letcalled=reffalseinletcallbacka=if!calledthenfailwith"on_response called multiple times!"elsecalled:=true;callbackainHandler.handlevalue~on_response:callback|_->raise_s[%message"Unrecognized variant"]);;letinjectv=Cvendletget_keyt=Obj.Extension_constructor.id(Obj.Extension_constructor.of_valt)lethandle_registered_event(T(t,cb))=Hashtbl.find_exnhandlers(get_keyt)(T(t,cb));;modulePrint_s=Define(structmoduleAction=Sexplethandles=print_ssend)letprint_s=Print_s.inject(* Effectful things *)type'at+=|Return:'a->'at|Lazy:'atLazy.t->'at|Bind:{t:'at;f:'a->'bt}->'bt|Map:{t:'at;f:'a->'b}->'bt|Never:'bt|Fun:(callback:('a->unit)->unit)->'atletreturna=Returnaletbind(typea)(t:at)~f=Bind{t;f}letmap(typeab)(t:at)~f:bt=Map{t;f}letnever=Neverletof_fun~f=Funfletlazy_a=LazyaincludeCore.Monad.Make(structtypenonrec'at='atletreturn=returnletbind=bindletmap=`Custommapend)letreceval:typea.at->callback:(a->unit)->unit=funt~callback->matchtwith|Funf->f~callback|Ignore->callback()|Returna->callbacka|Lazy(lazyt)->evalt~callback|Manyl->List.iterl~f:(eval~callback:ignore);callback()|Bind{t;f}->evalt~callback:(funa->eval(fa)~callback)|Map{t;f}->evalt~callback:(funa->callback(fa))|Never->()|t->handle_registered_event(T(t,callback));;moduleExpert=structlethandle=eval~callback:ignoretypehide=hidden=T:('at*('a->unit))->hidelethandlers=handlersletof_fun=of_funendmoduleAdvanced=structmoduleSync_fun_arg=structmoduleAction=structtype'rt=T:'a*('a->'r)->'rtendlethandle(Action.T(a,f))~on_response=on_response(fa)endmoduleSync_fun=Define1(Sync_fun_arg)letof_sync_funfa=Sync_fun.inject(T(a,f))modulePrivate=structmoduleCallback=structtypenonrec('a,'b)t={request:'a;on_response:'b->unitt}letmake~request~on_response={request;on_response}letrequest{request;_}=requestletrespond_to{on_response;_}response=on_responseresponseendletmake:request:'a->evaluator:(('a,'b)Callback.t->unitt)->'bt=fun~request~evaluator->Expert.of_fun~f:(fun~callback->letcallback=Callback.make~request~on_response:(funresponse->callbackresponse;Ignore)inExpert.handle(evaluatorcallback));;endmoduleFor_testing=structmoduleSvar=structtype'astate=|Emptyof{handlers:('a->unit)Bag.t}|Fullof'atype'at='astaterefletcreate()=ref(Empty{handlers=Bag.create()})letuponthandler=match!twith|Empty{handlers}->ignore(Bag.addhandlershandler:_Bag.Elt.t)|Fullx->handlerx;;letfill_if_emptytx=match!twith|Full_->()|Empty{handlers}->Bag.iterhandlers~f:(funhandler->handlerx);t:=Fullx;;letpeekt=match!twith|Empty_->None|Fullx->Somex;;endmoduleSvar_fun_arg=structmoduleAction=structtype'rt=T:'a*('a->'rSvar.t)->'rtendlethandle(Action.T(a,f))~on_response=Svar.upon(fa)on_responseendmoduleSvar_fun=Define1(Svar_fun_arg)letof_svar_funfa=Svar_fun.inject(T(a,f))moduleQuery_response_tracker=structtype('q,'r)rpc={query:'q;response:'rSvar.t}type('q,'r)t=('q,'r)rpcBag.tletcreate()=Bag.create()letadd_querytquery=letresponse=Svar.create()inignore(Bag.addt{query;response}:_Bag.Elt.t);response;;letqueries_pending_responset=Bag.to_listt|>List.map~f:(fun{query;response=_}->query);;type'rmaybe_respond=|No_response_yet|Respondof'rletmaybe_respondt~f=Bag.filter_inplacet~f:(fun{query;response}->matchfquerywith|No_response_yet->true|Respondresp->Svar.fill_if_emptyresponseresp;false);;endletof_query_response_trackerqrt=of_svar_fun(Query_response_tracker.add_queryqrt)endendincludeAdvanced