{-# LANGUAGE RankNTypes,
GADTs,
MultiParamTypeClasses,
FunctionalDependencies,
FlexibleInstances #-}-- | The module `Core` contains the basic functionality of the parser library.-- It defines the types and implementations of the elementary parsers and recognisers involved. moduleText.ParserCombinators.UU.Core(-- * ClassesIsParser,ExtAlternative(..),-- Provides (..),Eof(..),IsLocationUpdatedBy(..),StoresErrors(..),HasPosition(..),-- * Types-- ** The parser descriptorP(),-- ** The progress informationSteps(..),Cost,Progress,-- ** Auxiliary typesNat(..),Strings,-- * Functions-- ** Basic Parsersmicro,amb,pErrors,pPos,pEnd,pSwitch,pSymExt,-- pSym,-- ** Calling Parsersparse,parse_h,-- ** Acessing various components getZeroP,getOneP,-- ** Evaluating the online resulteval,-- ** Re-exported modulesmoduleControl.Applicative,moduleControl.Monad)whereimportControl.ApplicativeimportControl.MonadimportData.CharimportDebug.TraceimportData.Maybe-- | In the class `IsParser` we assemble the basic properties we expect parsers to have. The class itself does not have any methods. -- Most properties come directly from the standard -- "Control.Applicative" module. The class `ExtAlternative` contains some extra methods we expect our parsers to have.class(Alternativep,Applicativep,ExtAlternativep)=>IsParserpinstanceMonadPlus(Pst)wheremzero=emptymplus=(<|>)class(Alternativep)=>ExtAlternativepwhere-- | `<<|>` is the greedy version of `<|>`. If its left hand side parser can-- make any progress then it commits to that alternative. Can be used to make-- parsers faster, and even get a complete Parsec equivalent behaviour, with-- all its (dis)advantages. Intended use @p \<\<\|> q \<\<\|> r \<\|> x \<\|> y \<?> \"string\"@. Use with care! (<<|>)::pa->pa->pa-- | The parsers build a list of symbols which are expected at a specific point. -- This list is used to report errors.-- Quite often it is more informative to get e.g. the name of the non-terminal . -- The `<?>` combinator replaces this list of symbols by the string argument. (<?>)::pa->String->pa-- | `doNotInterpret` makes a parser opaque for abstract interpretation; used when permuting parsers-- where we do not want to compare lengths.doNotInterpret::pa->padoNotInterpret=id-- | `must_be_non_empty` checks whether its second argument-- is a parser which can recognise the empty input. If so, an error message is-- given using the String parameter. If not, then the third argument is-- returned. This is useful in testing for illogical combinations. For its use see-- the module "Text.ParserCombinators.UU.Derived".must_be_non_empty::String->pa->c->c---- | `must_be_non_empties` is similar to `must_be_non_empty`, but can be -- used in situations where we recognise a sequence of elements separated by -- other elements. This does not make sense if both parsers can recognise the -- empty string. Your grammar is then highly ambiguous.must_be_non_empties::String->pa->pb->c->c-- | If 'p' can be recognized, the return value of 'p' is used. Otherwise,-- the value 'v' is used. Note that `opt` by default is greedy. If you do not want-- this use @...\<\|> pure v@ instead. Furthermore, 'p' should not-- recognise the empty string, since this would make the parser ambiguous!!opt::pa->a->paoptpv=must_be_non_empty"opt"p(p<<|>purev)infix2<?>infixl3<<|>infixl2`opt`-- | The class `Eof` contains a function `eof` which is used to check whether we have reached the end of the input and `deletAtEnd` -- should discard any unconsumed input at the end of a successful parse.classEofstatewhereeof::state->BooldeleteAtEnd::state->Maybe(Cost,state)-- | The input state may maintain a location which can be used in generating error messages. -- Since we do not want to fix our input to be just a @String@ we provide an interface-- which can be used to advance this location by passing information about the part recognised. This function is typically-- called in the `splitState` functions.classShowloc=>loc`IsLocationUpdatedBy`strwhereadvance::loc-- ^ The current position->str-- ^ The part which has been removed from the input->loc-- | The class `StoresErrors` is used by the function `pErrors` which retrieves the generated -- correction steps since the last time it was called.--classstate`StoresErrors`error|state->errorwhere-- | `getErrors` retrieves the correcting steps made since the last time the function was called. The result can, -- by using it in a monad, be used to control how to proceed with the parsing process.getErrors::state->([error],state)classstate`HasPosition`pos|state->poswhere-- | `getPos` retrieves the correcting steps made since the last time the function was called. The result can, -- by using it as the left hand side of a monadic bind, be used to control how to proceed with the parsing process.getPos::state->pos-- | The data type `T` contains three components, all being some form of primitive parser. -- These components are used in various combinations,-- depending on whether you are in the right and side operand of a monad, -- whether you are interested in a result (if not, we use recognisers), -- and whether you want to have the results in an online way (future parsers), or just prefer to be a bit faster (history parsers)dataTsta=T(forallr.(a->st->Stepsr)->st->Stepsr)-- history parser(forallr.(st->Stepsr)->st->Steps(a,r))-- future parser(forallr.(st->Stepsr)->st->Stepsr)-- recogniser instanceFunctor(Tst)wherefmapf(Tphpfpr)=T(\k->ph(k.f))(\k->apply2fstf.pfk)-- pure f <*> pfprf<$(T__pr)=T(pr.($f))(\kst->pushf(prkst))prinstanceApplicative(Tstate)whereTphpfpr<*>~(Tqhqfqr)=T(\k->ph(\pr->qh(\qr->k(prqr))))((apply.).(pf.qf))(pr.qr)Tphpfpr<*~(T__qr)=T(ph.(qr.))(pf.qr)(pr.qr)T__pr*>~(Tqhqfqr)=T(pr.qh)(pr.qf)(pr.qr)purea=T($a)((pusha).)idinstanceAlternative(Tstate)whereTphpfpr<|>Tqhqfqr=T(\kinp->phkinp`best`qhkinp)(\kinp->pfkinp`best`qfkinp)(\kinp->prkinp`best`qrkinp)empty=T(\kinp->noAlts)(\kinp->noAlts)(\kinp->noAlts)dataPsta=P(Tsta)-- actual parsers(Maybe(Tsta))-- non-empty parsers; Nothing if they are absentNat-- minimal length of the non-empty part(Maybea)-- the possibly empty alternative with value instanceShow(Psta)whereshow(P_ntne)="P _ "++maybe"Nothing"(const"(Just _)")nt++" ("++shown++") "++maybe"Nothing"(const"(Just _)")e-- | `getOneP` retrieves the non-zero part from a descriptor.getOneP::Pab->Maybe(Pab)-- getOneP (P _ (Just _) (Zero Unspecified) _ ) = error "The element is a special parser which cannot be combined"getOneP(P_Nothingl_)=NothinggetOneP(P_oneplep)=Just(mkParseronepNothing(getLengthl))-- | `getZeroP` retrieves the possibly empty part from a descriptor.getZeroP::Pta->MaybeagetZeroP(P___z)=z-- | `mkParser` combines the non-empty descriptor part and the empty descriptor part into a descriptor tupled with the parser triplemkParser::Maybe(Tsta)->Maybea->Nat->PstamkParsernpnel=P(mkParser'npne)nplnewheremkParser'np@(Justnt)ne@Nothing=ntmkParser'np@Nothingne@(Justa)=pureamkParser'np@(Justnt)ne@(Justa)=nt<|>purea-- ! `combine` creates the non-empty parser combine::(Alternativef)=>Maybet1->Maybet2->t->Maybet3->(t1->t->fa)->(t2->t3->fa)->Maybe(fa)combineNothingNothing____=Nothing-- this Parser always failscombine(Justp)Nothingaq_op1op2=Just(p`op1`aq)combine(Justp)(Justv)aqnqop1op2=casenqofJustnnq->Just(p`op1`aq<|>v`op2`nnq)Nothing->Just(p`op1`aq)-- rhs contribution is just from empty altcombineNothing(Justv)_nq_op2=casenqofJustnnq->Just(v`op2`nnq)-- right hand side has non-empty partNothing->Nothing-- neither side has non-empty partinstanceFunctor(Pstate)wherefmapf(Papnplme)=mkParser(fmap(fmapf)np)(f<$>me)lf<$(Papnplme)=mkParser(fmap(f<$)np)(f<$me)linstanceApplicative(Pstate)wherePapnpplpe<*>~(Paqnqqlqe)=mkParser(combinenppeaqnq(<*>)(<$>))(pe<*>qe)(nat_addplql)Papnpplpe<*~(Paqnqqlqe)=mkParser(combinenppeaqnq(<*)(<$))(pe<*qe)(nat_addplql)Papnpplpe*>~(Paqnqqlqe)=mkParser(combinenppeaqnq(*>)(flipconst))(pe*>qe)(nat_addplql)purea=mkParserNothing(Justa)(ZeroInfinite)instanceAlternative(Pstate)wherePapnpplpe<|>Paqnqqlqe=let(rl,b)=trace'"calling natMin from <|>"(nat_minplql0)Nothing`alt`q=qp`alt`Nothing=pJustp`alt`Justq=Just(p<|>q)inmkParser((ifbthenidelseflip)altnpnq)(pe<|>qe)rlempty=mkParseremptyemptyInfiniteinstanceExtAlternative(Pst)wherePapnpplpe<<|>Paqnqqlqe=let(rl,b)=nat_minplql0bestx::Stepsa->Stepsa->Stepsabestx=(ifbthenidelseflip)bestchoose::Tsta->Tsta->Tstachoose(Tphpfpr)(Tqhqfqr)=T(\kst->letleft=norm(phkst)inifhas_successleftthenleftelseleft`bestx`qhkst)(\kst->letleft=norm(pfkst)inifhas_successleftthenleftelseleft`bestx`qfkst)(\kst->letleft=norm(prkst)inifhas_successleftthenleftelseleft`bestx`qrkst)inP(chooseapaq)(maybenp(\nqq->maybenq(\npp->return(choosenppnqq))np)nq)rl(pe<|>qe)-- due to the way Maybe is instance of Alternative the left hand operator gets priorityP_npplpe<?>label=letreplaceExpected::Stepsa->StepsareplaceExpected(Fail_c)=(Fail[label]c)replaceExpectedothers=othersnnp=casenpofNothing->NothingJust((Tphpfpr))->Just(T(\kinp->replaceExpected(norm(phkinp)))(\kinp->replaceExpected(norm(pfkinp)))(\kinp->replaceExpected(norm(prkinp))))inmkParsernnppepl-- | `doNotInterpret` forgets the computed minimal number of tokens recognised by this parserdoNotInterpret(Ptnep_e)=PtnepUnspecifiedemust_be_non_emptymsgp@(P__(Zero_)_)_=error("The combinator "++msg++" requires that it's argument cannot recognise the empty string\n")must_be_non_empty__q=qmust_be_non_emptiesmsg(P__(Zero_)_)(P__(Zero_)_)_=error("The combinator "++msg++" requires that not both arguments can recognise the empty string\n")must_be_non_empties___q=qinstanceIsParser(Pst)-- !! do not move the P constructor behind choices/patern matchesinstanceMonad(Pst)wherep@(Papnplpep)>>=a2q=(Pnewapnewnp(nat_addlp(error"cannot compute minimal length of right hand side of monadic parser"))newep)where(newep,newnp,newap)=caseepofNothing->(Nothing,t,maybeemptyidt)Justa->letPaqnqlqeq=a2qain(eq,combinetnq,t`alt`aq)Nothing`alt`q=qJustp`alt`q=p<|>qt=fmap(\(Th__)->(T(\k->h(\a->unParser_h(a2qa)k))(\k->h(\a->unParser_f(a2qa)k))(\k->h(\a->unParser_r(a2qa)k))))npcombineNothingNothing=Nothingcombinel@(Just_)Nothing=lcombineNothingr@(Just_)=rcombine(Justl)(Justr)=Just(l<|>r)-- | `unParser_h` retreives the history parser from the descriptorunParser_h::Pba->(a->b->Stepsr)->b->StepsrunParser_h(P(Th__)___)=h-- | `unParser_f` retreives the future parser from the descriptorunParser_f::Pba->(b->Stepsr)->b->Steps(a,r)unParser_f(P(T_f_)___)=f-- | `unParser_r` retreives therecogniser from the descriptorunParser_r::Pba->(b->Stepsr)->b->StepsrunParser_r(P(T__r)___)=rreturn=pure-- | The basic recognisers are written elsewhere (e.g. in our module "Text.ParserCombinataors.UU.BasicInstances"; -- they (i.e. the parameter `splitState`) are lifted to our`P` descriptors by the function `pSymExt` which also takes-- the minimal number of tokens recognised by the parameter `spliState` and an @Maybe@ value describing the possibly empty value.pSymExt::(foralla.(token->state->Stepsa)->state->Stepsa)->Nat->Maybetoken->PstatetokenpSymExtsplitStatele=mkParser(Justt)elwheret=T(splitState)(\k->splitState(\t->pusht.k))(\k->splitState(\_->k))-- | `micro` inserts a `Cost` step into the sequence representing the progress the parser is making; -- for its use see `"Text.ParserCombinators.UU.Demos.Examples"`micro::Pstatea->Int->PstateaP_npplpe`micro`i=letnnp=fmap(\(Tphpfpr)->(T(\kst->ph(\ast->Microi(kast))st)(\kst->pf(Microi.k)st)(\kst->pr(Microi.k)st)))npinmkParsernnppepl-- | For the precise functioning of the `amb` combinators see the paper cited in the "Text.ParserCombinators.UU.README";-- it converts an ambiguous parser into a parser which returns a list of possible recognitions,amb::Psta->Pst[a]amb(P_npplpe)=letcombinevalues::Steps[(a,r)]->Steps([a],r)combinevalueslar=Apply(\lar->(mapfstlar,snd(headlar)))larnnp=casenpofNothing->NothingJust((Tphpfpr))->Just(T(\k->removeEnd_h.ph(\ast'->End_h([a],\as->kasst')noAlts))(\kinp->combinevalues.removeEnd_f$pf(\st->End_f[kst]noAlts)inp)(\k->removeEnd_h.pr(\st'->End_h([undefined],\_->kst')noAlts)))nep=(fmappurepe)inmkParsernnpneppl-- | `pErrors` returns the error messages that were generated since its last call.pErrors::StoresErrorssterror=>Pst[error]pErrors=letnnp=Just(T(\kinp->let(errs,inp')=getErrorsinpinkerrsinp')(\kinp->let(errs,inp')=getErrorsinpinpusherrs(kinp'))(\kinp->let(errs,inp')=getErrorsinpinkinp'))nep=(Just(error"pErrors cannot occur in lhs of bind"))-- the errors consumed cannot be determined statically!inmkParsernnpNothing(ZeroInfinite)-- | `pPos` returns the current input position.pPos::HasPositionstpos=>PstpospPos=letnnp=Just(T(\kinp->letpos=getPosinpinkposinp)(\kinp->letpos=getPosinpinpushpos(kinp))(\kinp->kinp))nep=Just(error"pPos cannot occur in lhs of bind")-- the errors consumed cannot be determined statically!inmkParsernnpNothing(ZeroInfinite)-- | `pState` returns the current input statepState::PststpState=letnnp=Just(T(\kinp->kinpinp)(\kinp->pushinp(kinp))($))inmkParsernnpNothing(ZeroInfinite)-- | The function `pEnd` should be called at the end of the parsing process. It deletes any unconsumed input, turning it into error messages.pEnd::(StoresErrorssterror,Eofst)=>Pst[error]pEnd=letnnp=Just(T(\kinp->letdeleterestinp=casedeleteAtEndinpofNothing->let(finalerrors,finalstate)=getErrorsinpinkfinalerrorsfinalstateJust(i,inp')->Fail[][const(i,deleterestinp')]indeleterestinp)(\kinp->letdeleterestinp=casedeleteAtEndinpofNothing->let(finalerrors,finalstate)=getErrorsinpinpushfinalerrors(kfinalstate)Just(i,inp')->Fail[][const((i,deleterestinp'))]indeleterestinp)(\kinp->letdeleterestinp=casedeleteAtEndinpofNothing->let(finalerrors,finalstate)=getErrorsinpin(kfinalstate)Just(i,inp')->Fail[][const(i,deleterestinp')]indeleterestinp))inmkParsernnpNothing(ZeroInfinite)-- | @`pSwitch`@ takes the current state and modifies it to a different type of state to which its argument parser is applied. -- The second component of the result is a function which converts the remaining state of this parser back into a value of the original type.-- For the second argument to @`pSwitch`@ (say split) we expect the following to hold:-- -- > let (n,f) = split st in f n == stpSwitch::(st1->(st2,st2->st1))->Pst2a->Pst1a-- we require let (n,f) = split st in f n to be equal to stpSwitchsplit(P_npplpe)=letnnp=fmap(\(Tphpfpr)->T(\kst1->let(st2,back)=splitst1inph(\ast2'->ka(backst2'))st2)(\kst1->let(st2,back)=splitst1inpf(\st2'->k(backst2'))st2)(\kst1->let(st2,back)=splitst1inpr(\st2'->k(backst2'))st2))npinmkParsernnppepl-- | The function @`parse`@ shows the prototypical way of running a parser on-- some specific input.-- By default we use the future parser, since this gives us access to partal-- result; future parsers are expected to run in less space.parse::(Eoft)=>Pta->t->aparse(P(T_pf_)___)=fst.eval.pf(\rest->ifeofrestthenStep0(Step0(Step0(Step0(error"ambiguous parser?"))))elseerror"pEnd missing?")-- | The function @`parse_h`@ behaves like @`parse`@ but using the history-- parser. This parser does not give online results, but might run faster.parse_h::(Eoft)=>Pta->t->aparse_h(P(Tph__)___)=fst.eval.ph(\arest->ifeofrestthenpusha(Step0(Step0(Step0(Step0(error"ambiguous parser?")))))elseerror"pEnd missing?")-- | The data type `Steps` is the core data type around which the parsers are constructed.-- It describes a tree structure of streams containing (in an interleaved way) both the online result of the parsing process,-- and progress information. Recognising an input token should correspond to a certain amount of @`Progress`@, -- which tells how much of the input state was consumed. -- The @`Progress`@ is used to implement the breadth-first search process, in which alternatives are-- examined in a more-or-less synchronised way. The meaning of the various @`Step`@ constructors is as follows:---- [`Step`] A token was succesfully recognised, and as a result the input was 'advanced' by the distance @`Progress`@---- [`Apply`] The type of value represented by the `Steps` changes by applying the function parameter.---- [`Fail`] A correcting step has to be made to the input; the first parameter contains information about what was expected in the input, -- and the second parameter describes the various corrected alternatives, each with an associated `Cost`---- [`Micro`] A small cost is inserted in the sequence, which is used to disambiguate. Use with care!---- The last two alternatives play a role in recognising ambigous non-terminals. For a full description see the technical report referred to from -- "Text.ParserCombinators.UU.README".dataStepsawhereStep::Progress->Stepsa->StepsaApply::forallab.(b->a)->Stepsb->StepsaFail::Strings->[Strings->(Cost,Stepsa)]->StepsaMicro::Int->Stepsa->StepsaEnd_h::([a],[a]->Stepsr)->Steps(a,r)->Steps(a,r)End_f::[Stepsa]->Stepsa->StepsatypeCost=InttypeProgress=InttypeStrings=[String]apply::Steps(b->a,(b,r))->Steps(a,r)apply=Apply(\(b2a,br)->let(b,r)=brin(b2ab,r))push::v->Stepsr->Steps(v,r)pushv=Apply(\r->(v,r))apply2fst::(b->a)->Steps(b,r)->Steps(a,r)apply2fstf=Apply(\(b,r)->(fb,r))succeedAlways::StepsasucceedAlways=letsteps=Step0stepsinstepsfailAlways::StepsafailAlways=Fail[][const(0,failAlways)]noAlts::StepsanoAlts=Fail[][]has_success::Stepst->Boolhas_success(Step__)=Truehas_success_=False-- | @`eval`@ removes the progress information from a sequence of steps, and constructs the value embedded in it.-- If you are really desparate to see how your parsers are making progress (e.g. when you have written an ambiguous parser, and you cannot find the cause of-- the exponential blow-up of your parsing process), you may switch on the trace in the function @`eval`@ (you will need to edit the library source code).-- eval::Stepsa->aeval(Stepnl)={- trace ("Step " ++ show n ++ "\n")-}(evall)eval(Micro_l)=evalleval(Failssls)=trace'("expecting: "++showss)(eval(getCheapest3(map($ss)ls)))eval(Applyfl)=f(evall)eval(End_f__)=error"dangling End_f constructor"eval(End_h__)=error"dangling End_h constructor"-- | `norm` makes sure that the head of the seqeunce contains progress information. -- It does so by pushing information about the result (i.e. the `Apply` steps) backwards.--norm::Stepsa->Stepsanorm(Applyf(Steppl))=Stepp(Applyfl)norm(Applyf(Microcl))=Microc(Applyfl)norm(Applyf(Failssls))=Failss(applyFail(Applyf)ls)norm(Applyf(Applygl))=norm(Apply(f.g)l)norm(Applyf(End_fssl))=End_f(map(Applyf)ss)(Applyfl)norm(Applyf(End_h__))=error"Apply before End_h"normsteps=stepsapplyFail::(c->d)->[a->(b,c)]->[a->(b,d)]applyFailf=map(\g->\ex->let(c,l)=gexin(c,fl))-- | The function @best@ compares two streamsbest::Stepsa->Stepsa->Stepsax`best`y=normx`best'`normybest'::Stepsb->Stepsb->StepsbEnd_fasl`best'`End_fbsr=End_f(as++bs)(l`best`r)End_fasl`best'`r=End_fas(l`best`r)l`best'`End_fbsr=End_fbs(l`best`r)End_h(as,k_h_st)l`best'`End_h(bs,_)r=End_h(as++bs,k_h_st)(l`best`r)End_hasl`best'`r=End_has(l`best`r)l`best'`End_hbsr=End_hbs(l`best`r)Failslll`best'`Failsrrr=Fail(sl++sr)(ll++rr)Fail__`best'`r=r-- <----------------------------- to be refinedl`best'`Fail__=lStepnl`best'`Stepmr|n==m=Stepn(l`best`r)|n<m=Stepn(l`best`Step(m-n)r)|n>m=Stepm(Step(n-m)l`best`r)ls@(Step__)`best'`Micro__=lsMicro__`best'`rs@(Step__)=rsls@(Microil)`best'`rs@(Microjr)|i==j=Microi(l`best`r)|i<j=ls|i>j=rsl`best'`r=error"missing alternative in best'"-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-- %%%%%%%%%%%%% getCheapest %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%getCheapest::Int->[(Int,Stepsa)]->StepsagetCheapest_[]=error"no correcting alternative found"getCheapestnl=snd$foldr(\(w,ll)btf@(c,l)->ifw<c-- c is the best cost estimate thus far, and w total costs on this paththenletnew=(traversenllwc)inifnew<cthen(new,ll)elsebtfelsebtf)(maxBound,error"getCheapest")ltraverse::Int->Stepsa->Int->Int->Inttraverse0_vc=trace'("traverse "++show'0vc++" choosing"++showv++"\n")vtraversen(Step_l)vc=trace'("traverse Step "++show'nvc++"\n")(traverse(n-1)l(v-n)c)traversen(Microxl)vc=trace'("traverse Micro "++show'nvc++"\n")(traversenlvc)traversen(Apply_l)vc=trace'("traverse Apply "++shown++"\n")(traversenlvc)traversen(Failmm2ls)vc=trace'("traverse Fail "++showm++show'nvc++"\n")(foldr(\(w,l)c'->ifv+w<c'thentraverse(n-1)l(v+w)c'elsec')c(map($m)m2ls))traversen(End_h((a,lf))r)vc=traversen(lfa`best`removeEnd_hr)vctraversen(End_f(l:_)r)vc=traversen(l`best`r)vcshow'::(Showa,Showb,Showc)=>a->b->c->Stringshow'nvc="n: "++shown++" v: "++showv++" c: "++showc-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-- %%%%%%%%%%%%% Handling ambiguous paths %%%%%%%%%%%%%%%%%%%-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%removeEnd_h::Steps(a,r)->StepsrremoveEnd_h(Failmls)=Failm(applyFailremoveEnd_hls)removeEnd_h(Steppsl)=Stepps(removeEnd_hl)removeEnd_h(Applyfl)=error"not in history parsers"removeEnd_h(Microcl)=Microc(removeEnd_hl)removeEnd_h(End_h(as,k_st)r)=k_stas`best`removeEnd_hrremoveEnd_f::Stepsr->Steps[r]removeEnd_f(Failmls)=Failm(applyFailremoveEnd_fls)removeEnd_f(Steppsl)=Stepps(removeEnd_fl)removeEnd_f(Applyfl)=Apply(map'f)(removeEnd_fl)wheremap'f~(x:xs)=fx:mapfxsremoveEnd_f(Microcl)=Microc(removeEnd_fl)removeEnd_f(End_f(s:ss)r)=Apply(:(mapevalss))s`best`removeEnd_fr-- ** The type @`Nat`@ for describing the minimal number of tokens consumed-- | The data type @`Nat`@ is used to represent the minimal length of a parser.-- Care should be taken in order to not evaluate the right hand side of the binary function @`nat-add`@ more than necesssary.dataNat=ZeroNat-- the length of the non-zero part of the parser is remembered)|SuccNat|Infinite|UnspecifiedderivingShow-- | `getlength` retrieves the length of the non-empty part of a parsergetLength::Nat->NatgetLength(Zerol)=lgetLengthl=l-- | `nat_min` compares two minmal length and returns the shorter length. The second component indicates whether the left-- operand is the smaller one; we cannot use @Either@ since the first component may already be inspected -- before we know which operand is finally chosennat_min::Nat->Nat->Int->(Nat-- the actual minimum length,Bool-- whether aternatives should be swapped)nat_min(Zerol)(Zeror)n=trace'"Both Zero in nat_min\n"(Zero(trace'"Should not be called unless merging?"(fst(nat_minlr(n+1)))),False)nat_minlrr@(Zeror)n=trace'"Right Zero in nat_min\n"(let(m,_)=nat_minlr(n+1)in(Zerom,True))nat_minll@(Zerol)rn=trace'"Left Zero in nat_min\n"(let(m,_)=nat_minlr(n+1)in(Zerom,False))nat_min(Succll)(Succrr)n=ifn>1000thenerror"problem with comparing lengths"elsetrace'("Succ in nat_min "++shown++"\n")(let(v,b)=nat_minllrr(n+1)in(Succv,b))nat_minInfiniter_=trace'"Left Infinite in nat_min\n"(r,True)nat_minlInfinite_=trace'"Right Infinite in nat_min\n"(l,False)nat_minUnspecifiedr_=trace'"Left Unspecified in nat_min\n"(r,False)-- leave the alternatives in the order they are nat_minlUnspecified_=trace'"Right Unspecified in nat_min\n"(l,False)-- leave the alternatives in the order they arenat_add::Nat->Nat->Natnat_addUnspecified_=trace'"Unspecified in add\n"Unspecifiednat_addInfinite_=trace'"Infinite in add\n"Infinitenat_add(Zero_)r=trace'"Zero in add\n"rnat_add(Succl)r=trace'"Succ in add\n"(Succ(nat_addlr))trace'::String->b->btrace'mv={- trace m -}v