Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Source file generic.ml
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447openFmlib_stdopenInterfacesmoduleMake(Token:ANY)(State:ANY)(Expect:ANY)(Semantic:ANY)(Final:ANY)=structmoduleB=Buffer.Make(State)(Token)(Expect)(Semantic)moduleError=Error.Make(Expect)(Semantic)moduleParser=structtypet=|MoreofB.t*(B.t->t)|DoneofB.t*Final.toptionletneeds_more(p:t):bool=matchpwith|More_->true|Done_->falselethas_ended(p:t):bool=not(needs_morep)lethas_succeeded(p:t):bool=matchpwith|Done(_,Some_)->true|_->falseletfinal(p:t):Final.t=assert(has_succeededp);matchpwith|Done(_,Somev)->v|_->assertfalse(* Illegal call. *)lethas_failed_syntax(p:t):bool=matchpwith|Done(b,None)whenError.is_syntax(B.errorb)->true|_->falselethas_failed_semantic(p:t):bool=matchpwith|Done(b,None)whenError.is_semantic(B.errorb)->true|_->falseletfailed_expectations(p:t):Expect.tlist=assert(has_failed_syntaxp);matchpwith|Done(b,None)whenError.is_syntax(B.errorb)->Error.expectations(B.errorb)|_->assertfalseletfailed_semantic(p:t):Semantic.t=assert(has_failed_semanticp);matchpwith|Done(b,None)whenError.is_semantic(B.errorb)->Error.semantic(B.errorb)|_->assertfalseletrecconsume_lookaheads(p:t):t=(* As long as there are lookaheads in the buffer, consume them. *)matchpwith|More(b,f)whenB.has_lookaheadb->consume_lookaheads(fb)|_->pletput(t:Token.t)(p:t):t=letput=function|More(b,f)->More(B.push_tokentb,f)|Done(b,res)->Done(B.push_tokentb,res)inputp|>consume_lookaheadsletput_end(p:t):t=letput=function|More(b,f)->More(B.push_endb,f)|Done(b,res)->Done(B.push_endb,res)inputp|>consume_lookaheadsletstate(p:t):State.t=matchpwith|More(b,_)|Done(b,_)->B.statebletlookaheads(p:t):Token.tarray*bool=matchpwith|More(b,_)|Done(b,_)->B.lookaheadsb,B.has_endbend(* The parsing combinators
-----------------------
A parsing combinator is a continuation monad with state. The state is the
parse buffer.
*)typestate=State.ttypeexpect=Expect.ttypesemantic=Semantic.ttype'acont='aoption->B.t->Parser.ttype'at=B.t->'acont->Parser.tletreturn(a:'a):'at=funbk->k(Somea)bletsucceed(a:'a):'at=funbk->k(Somea)(B.clear_errorsb)letclear_last_expectation(a:'a):'at=funbk->k(Somea)(B.clear_last_errorb)letfail(e:Semantic.t):'at=funbk->kNone(B.put_erroreb)letunexpected(exp:Expect.t):'at=funbk->kNone(B.add_expectedexpb)let(>>=)(p:'at)(f:'a->'bt):'bt=funbk->pb(funob->matchowith|Somea->fabk|None->kNoneb)let(let*)=(>>=)letmap(f:'a->'b)(p:'at):'bt=let*a=pinreturn(fa)letupdate(f:State.t->State.t):unitt=funbk->k(Some())(B.updatefb)letget:State.tt=funbk->k(Some(B.stateb))bletget_and_update(f:State.t->State.t):State.tt=funbk->letst=B.statebink(Somest)(B.updatefb)(* Basic Combinators *)letstep(f:State.t->Token.toption->('a*State.t,Expect.t)result):'at=(* Basic parsing combinator which handles one token.
The handling function [f] receives the current state and the current
lookahead token and return a result on how to handle it.
Success case: An item and a new state.
Error case: A message of what has been expected by the combinator.
*)funbk->More(b,funb->assert(B.has_lookaheadb);matchf(B.stateb)(B.first_lookaheadb)with|Ok(a,s1)->k(Somea)(B.consumes1b)|Errore->kNone(B.rejecteb))letexpect_end(e:State.t->Expect.t)(a:'a):'at=step(funstatetoken->matchtokenwith|None->Ok(a,state)|Some_->Error(estate))letmake_parser(s:State.t)(p:Final.tt):Parser.t=p(B.inits)(funresb->Done(b,res))letmake(state:State.t)(p:Final.tt)(e:State.t->Expect.t):Parser.t=make_parserstate(p>>=expect_ende)letconsumer(p:'at):'at=(* Execute [p].
Precondition: [p] must consume at least one token in case of success.
*)funb0k->p(B.start_new_consumerb0)(funresb->letconsumed=B.has_consumedbinassert(res=None||consumed);kres(B.end_new_consumerb0b))let(</>)(p:'at)(q:'at):'at=(* Try [p]. If it fails without consuming token, then try [q ()]. *)funb0k->p(B.start_new_consumerb0)(funresb->letconsumed=B.has_consumedbinletb=B.end_new_consumerb0binmatchreswith|Nonewhennotconsumed->(* p failed and did not consume token *)qbk|_->(* p did consume token and succeeded or failed. *)kresb)let(<?>)(p:'at)(e:Expect.t):'at=funb0k->p(B.start_alternativesb0)(funresb->matchreswith|None->kNone(B.end_failed_alternativeseb0b)|Somea->k(Somea)(B.end_succeeded_alternativesb0b))letbacktrack(p:'at)(e:Expect.t):'at=funb0k->p(B.start_backtrackb0)(funresb->kres(matchreswith|None->B.end_backtrack_fail(Somee)b0b|Some_->B.end_backtrack_successb0b))letnot_followed_by(p:'at)(exp:Expect.t):unitt=funb0k->p(B.start_backtrackb0)(funresb->matchreswith|None->k(Some())(B.end_backtrack_failNoneb0b)|Some_->kNone(B.end_backtrack_fail(Someexp)b0b))letfollowed_by(p:'at)(exp:Expect.t):'at=funb0k->p(B.start_backtrackb0)(funresb->matchreswith|None->kNone(B.end_backtrack_fail(Someexp)b0b)|Somea->k(Somea)(B.end_backtrack_failNoneb0b))letoptional(p:'at):'aoptiont=(let*a=pinreturn(Somea))</>returnNoneletrecchoices(p:'at)(qs:'atlist):'at=matchqswith|[]->p|q::qs->choices(p</>q)qsletzero_or_more(start:'r)(f:'item->'r->'r)(p:'itemt):'rt=letrecmanyr=(let*a=consumerpinmany(far))</>returnrinmanystartletone_or_more(first:'item->'r)(next:'item->'r->'r)(p:'itemt):'rt=let*a=pinzero_or_more(firsta)nextpletlist_zero_or_more(p:'at):'alistt=let*xs=zero_or_more[](funxxs->x::xs)pinreturn(List.revxs)letlist_one_or_more(p:'at):('a*'alist)t=let*x=pinlet*xs=list_zero_or_morepinreturn(x,xs)letskip_zero_or_more(p:'at):intt=zero_or_more0(fun_i->i+1)pletskip_one_or_more(p:'at):intt=let*n=skip_zero_or_morepinlet*_=pinreturn(n+1)letone_or_more_separated(first:'item->'r)(next:'r->'sep->'item->'r)(p:'itemt)(sep:'sept):'rt=letrecmanyr=(let*s=sepinlet*item=pinmany(nextrsitem))</>returnrinlet*item=pinmany(firstitem)(*
let one_or_more_separated (p: 'a t) (sep: _ t): 'a list t =
return (fun a l -> a :: l)
|= p
|= zero_or_more (sep >>= fun _ -> p)
let zero_or_more_separated (p: 'a t) (sep: _ t): 'a list t =
one_or_more_separated p sep
</> return []*)end(* Make *)