-- | The module `Core` contains the basic functionality of the parser library. -- It takes care of the breadth-first search, the online generation of results, the core error-- correction administration, dealing with ambigous grammars, and the type for both kinds of parsers-- involved and the recognisers.{-# LANGUAGE RankNTypes,
GADTs,
MultiParamTypeClasses,
FunctionalDependencies,
FlexibleInstances,
FlexibleContexts,
UndecidableInstances,
NoMonomorphismRestriction,
ImpredicativeTypes #-}moduleText.ParserCombinators.UU.Core(moduleText.ParserCombinators.UU.Core,moduleControl.Applicative)whereimportControl.Applicativehiding((<*),(*>),(<$),many,some,optional)importCharimportDebug.TraceimportMaybe{-
infixl 4 <*, *>
infixl 4 <$
-}-- * The Classes Defining the Interface-- ** `IsParser`-- | This class collects a number of classes which together defines what a `Parser` should provide. -- Since it is just a predicate we have prefixed the name by the phrase `Is'class(Applicativep,ExtApplicativep,Alternativep)=>IsParserpwhereinstance(Applicativep,ExtApplicativep,Alternativep)=>IsParserpwhereinfixl4<*,*>infixl4<$-- ** `ExtApplicative'-- | The module "Control.Applicative" contains definitions for `<$`, `*>` and `<*` which cannot be changed. Since we want to give-- optimised implementations of these combinators, we hide those definitions, and define a class containing their signatures.classExtApplicativepwhere(<*)::pa->pb->pa(*>)::pb->pa->pa(<$)::a->pb->pa-- ** `Symbol'-- | Many parsing libraries do not make a distinction between the terminal symbols of the language recognised and the -- tokens actually constructed from the input. This happens e.g. if we want to recognise an integer or an identifier: we are also interested in which integer occurred in the input, or which identifier. Note that if the alternative later fails repair will take place, instead of trying the other altrenatives at the greedy choice point.classSymbolpsymboltoken|psymbol->tokenwherepSym::symbol->ptoken-- ^ The function `pSym` takes as argument a value of some type `symbol', and returns a value of type `token'. The parser will in general depend on some -- state which is maintained holding the input. The functional dependency fixes the `token` type, based on the `symbol` type and the type of the parser `p`.-- Since `pSym' is overloaded both the type and the value of symbol determine how to decompose the input in a `token` and the remaining input.-- ** `Provides'classProvidesstatesymboltoken|statesymbol->tokenwheresplitState::symbol->(token->state->Stepsa)->state->Stepsa-- ** `Eof'classEofstatewhereeof::state->BooldeleteAtEnd::state->Maybe(Cost,state)-- * Progress Information-- | The data type `Steps` is the core data type around which the parsers are constructed. It is a stream containing both the result of the parsing process,-- albeit often in a fragmented way, and progress information. Recognising a token should correspond to a certain amount of `Progress`, -- which for the time being in an `Int`.---- [@`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 made to the input; the first parameter contains the error messages coresponding to the possible-- correcting steps, and the second parameter generated the various corrected alternatives, each with an associated `Cost`---- The last two alternatives play a role in recognising ambigous non-terminals. For a full description see the technical report.typeCost=InttypeProgress=IntdataStepsawhereStep::Progress->Stepsa->StepsaApply::forallb.(b->a)->Stepsb->StepsaFail::Strings->[Strings->(Cost,Stepsa)]->StepsaEnd_h::([a],[a]->Stepsr)->Steps(a,r)->Steps(a,r)End_f::[Stepsa]->Stepsa->StepsafailAlways=Fail[][const(0,failAlways)]noAlts=Fail[][]eval::Stepsa->aeval(Step_l)=evalleval(Failssls)=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"push::v->Stepsr->Steps(v,r)pushv=Apply(\r->(v,r))apply::Steps(b->a,(b,r))->Steps(a,r)apply=Apply(\(b2a,~(b,r))->(b2ab,r))norm::Stepsa->Stepsanorm(Applyf(Steppl))=Stepp(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=stepsapplyFailf=map(\g->\ex->let(c,l)=gexin(c,fl))best::Stepsa->Stepsa->Stepsax`best`y=normx`best'`normybest'::Stepsb->Stepsb->StepsbFailslll`best'`Failsrrr=Fail(sl++sr)(ll++rr)Fail__`best'`r=rl`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)End_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)l`best'`r=l`best`r-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-- %%%%%%%%%%%%% getCheapest %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-- The function getCheapest::Int->[(Int,Stepsa)]->StepsagetCheapest_[]=error"no correcting alternative found"getCheapestnl=snd$foldr(\(w,ll)btf@(c,l)->ifw<cthenletnew=(traversenllwc)inifnew<cthen(new,ll)elsebtfelsebtf)(maxBound,error"getCheapest")ltraverse::Int->Stepsa->Int->Int->Inttraverse0_=\vc->vtraversen(Step_l)=traverse(n-1)ltraversen(Apply_l)=traversenltraversen(Failmm2ls)=\vc->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)=traversen(lfa`best`removeEnd_hr)traversen(End_f(l:_)r)=traversen(l`best`r)-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-- %%%%%%%%%%%%% Parsers %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-- do not change into data, or be prepared to add ~ at subtle places !!newtypePsta=P(forallr.(a->st->Stepsr)->st->Stepsr-- history parser,forallr.(st->Stepsr)->st->Steps(a,r)-- future parser,forallr.(st->Stepsr)->st->Stepsr-- recogniser)unP(Pp)=pinstanceFunctor(Pstate)wherefmapf(P(ph,pf,pr))=P(\k->ph(k.f),\kinp->Apply(\(a,r)->(fa,r))(pfkinp)-- pure f <*> pf,pr)instanceApplicative(Pstate)whereP(ph,pf,pr)<*>P~(qh,qf,qr)=P(\k->ph(\pr->qh(\qr->k(prqr))),(apply.).(pf.qf),pr.qr)purea=P(($a),((pusha).),id)instanceAlternative(Pstate)whereP(ph,pf,pr)<|>P(qh,qf,qr)=P(\kinp->phkinp`best`qhkinp,\kinp->pfkinp`best`qfkinp,\kinp->prkinp`best`qrkinp)empty=P(\kinp->noAlts,\kinp->noAlts,\kinp->noAlts)instance(Providesstatesymboltoken)=>Symbol(Pstate)symboltokenwherepSyma=P(\kinp->splitStateakinp,\kinp->splitStatea(\tinp'->pusht(kinp'))inp,\kinp->splitStatea(\vinp'->kinp')inp)dataIda=IdaderivingShow-- parse_h (P (ph, pf, pr)) = fst . eval . ph (\ a rest -> if eof rest then push a failAlways else error "pEnd missing?") parse(P(ph,pf,pr))=fst.eval.pf(\rest->ifeofrestthenfailAlwayselseerror"pEnd missing?")-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-- %%%%%%%%%%%%% Monads %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%unParser_h(P(h,_,_))=hunParser_f(P(_,f,_))=funParser_r(P(_,_,r))=rinstanceMonad(Pst)whereP(ph,pf,pr)>>=a2q=P(\k->ph(\a->unParser_h(a2qa)k),\k->ph(\a->unParser_f(a2qa)k),\k->ph(\a->unParser_r(a2qa)k))return=pure-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-- %%%%%%%%%%%%% Greedy %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%best_gr::Stepsa->Stepsa->Stepsal@(Step__)`best_gr`_=ll`best_gr`r=l`best`rP(ph,pf,pr)<<|>P(qh,qf,qr)=P(\kst->norm(phkst)`best_gr`norm(qhkst),\kst->norm(pfkst)`best_gr`norm(qfkst),\kst->norm(prkst)`best_gr`norm(qrkst))-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-- %%%%%%%%%%%%% Ambiguous %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%amb::Psta->Pst[a]amb(P(ph,pf,pr))=P(\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))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(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)removeEnd_f(End_f(s:ss)r)=Apply(:(mapevalss))s`best`removeEnd_frcombinevalues::Steps[(a,r)]->Steps([a],r)combinevalueslar=Apply(\lar->(mapfstlar,snd(headlar)))larmap'f~(x:xs)=fx:mapfxs-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-- %%%%%%%%%%%%% pErrors %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%classstate`Stores`errors|state->errorswheregetErrors::state->(errors,state)pErrors::Storessterrors=>PsterrorspEnd::(Storessterrors,Eofst)=>PsterrorspErrors=P(\kinp->let(errs,inp')=getErrorsinpinkerrsinp',\kinp->let(errs,inp')=getErrorsinpinpusherrs(kinp'),\kinp->let(errs,inp')=getErrorsinpinkinp')pEnd=P(\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){-
-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-- %%%%%%%%%%%%% Microsteps %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
class MicroStep result where
microstep :: result a -> result a
instance MicroStep Steps where
microstep steps = Micro steps
class Micro p where
micro :: p a -> p a
instance Micro (P_f st) where
micro (P_f p) = P_f (\k st -> microstep ( p k st ) )
-}-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-- %%%%%%%%%%%%% State Change %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%pSwitch::(st1->(st2,st2->st1))->Pst2a->Pst1apSwitchsplit(P(ph,pf,pr))=P(\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)instanceExtApplicative(Pst)whereP(ph,pf,pr)<*P~(_,_,qr)=P(ph.(qr.),pf.qr,pr.qr)P(_,_,pr)*>P~(qh,qf,qr)=P(pr.qh,pr.qf,pr.qr)f<$P~(_,_,qr)=P(qr.($f),\kst->pushf(qrkst),qr)typeStrings=[String]