{-# LANGUAGE UndecidableInstances, GADTs, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-}-- Copyright (c) Jean-Philippe Bernardy 2007-8{- |
This is a library of interactive processes combinators, usable to
define extensible keymaps.
(Inspired by the Parsec library, written by Koen Claessen)
The processes are:
* composable: in parallel using '<|>', in sequence using monadic bind.
* extensible: it is always possible to override a behaviour by combination of
'adjustPriority' and '<|>'. (See also '<||' for a convenient combination of the two.)
* monadic: sequencing is done via monadic bind. (leveraging the whole
battery of monadic tools that Haskell provides)
The processes can parse input, and write output that depends on it.
The semantics are quite obvious; only disjunction
deserve a bit more explanation:
in @p = (a '<|>' b)@, what happens if @a@ and @b@ recognize the same
input (prefix), but produce conflicting output?
* if the output is the same (as by the PEq class), then the processes (prefixes) are "merged"
* if a Write is more prioritized than the other, the one with low priority will be discarded
* otherwise, the output will be delayed until one of the branches can be discarded.
* if there is no way to disambiguate, then no output will be generated anymore.
This situation can be detected by using 'possibleActions' however.
-}moduleYi.Interact(I,P(Chain,End),InteractState(..),MonadInteract(..),PEq(..),deprioritize,(<||),(||>),option,oneOf,processOneEvent,computeState,event,events,choice,mkAutomaton,idAutomaton,runWrite,anyEvent,eventBetween,accepted)whereimportControl.Arrow(first)importControl.Monad.Statehiding(get,mapM)importData.MonoidimportYi.PreludeimportPrelude()importData.MaybeimportData.List(filter,map,groupBy)-------------------------------------------------- ClassesclassPEqawhereequiv::a->a->Bool-- | Abstraction of monadic interactive processesclass(PEqw,Monadm,Alternativem,Applicativem,MonadPlusm)=>MonadInteractmwe|m->wewherewrite::w->m()-- ^ Outputs a result.eventBounds::Orde=>Maybee->Maybee->me-- ^ Consumes and returns the next character.-- Fails if there is no input left, or outside the given bounds.adjustPriority::Int->m()--------------------------------------------------- State transformation-- Needs -fallow-undecidable-instances-- TODO: abstract over MonadTransformerinstanceMonadInteractmwe=>MonadInteract(StateTsm)wewherewrite=lift.writeeventBoundslh=lift(eventBoundslh)adjustPriorityp=lift(adjustPriorityp)----------------------------------------------------------------------------- | Interactive process description-- TODO: Replace 'Doc:' by ^ when haddock supports GADTsdataIevwawhereReturns::a->IevwaBinds::Ievwa->(a->Ievwb)->IevwbGets::Ordev=>Maybeev->Maybeev->Ievwev-- Doc: Accept any character between given bounds. Bound is ignored if 'Nothing'.Fails::IevwaWrites::w->Ievw()Priority::Int->Ievw()Plus::Ievwa->Ievwa->IevwainstanceFunctor(Ieventw)wherefmapfi=puref<*>iinstanceApplicative(Ievw)wherepure=returna<*>b=dof<-a;x<-b;return(fx)instanceAlternative(Ievw)whereempty=Fails(<|>)=PlusinstanceMonad(Ieventw)wherereturn=Returnsfail_=Fails(>>=)=BindsinstancePEqw=>MonadPlus(Ieventw)wheremzero=Failsmplus=PlusinstancePEqw=>MonadInteract(Ieventw)weventwherewrite=WriteseventBounds=GetsadjustPrioritydp=Prioritydpinfixl3<||deprioritize::(MonadInteractfwe)=>f()deprioritize=adjustPriority1(<||),(||>)::(MonadInteractfwe)=>fa->fa->faa<||b=a<|>(deprioritize>>b)(||>)=flip(<||)-- | Convert a process description to an "executable" process.mkProcess::PEqw=>Ievwa->((a->Pevw)->Pevw)mkProcess(Returnsx)=\fut->futxmkProcessFails=(\_fut->Fail)mkProcess(m`Binds`f)=\fut->(mkProcessm)(\a->mkProcess(fa)fut)mkProcess(Getslh)=GetlhmkProcess(Writesw)=\fut->Writew(fut())mkProcess(Priorityp)=\fut->Priorp(fut())mkProcess(Plusab)=\fut->Best(mkProcessafut)(mkProcessbfut)------------------------------------------------------------------------ Process type-- | Operational representation of a processdataPeventw=Ordevent=>Get(Maybeevent)(Maybeevent)(event->Peventw)|Fail|Writew(Peventw)|PriorInt(Peventw)-- low numbers indicate high priority|Best(Peventw)(Peventw)|End|forallmid.(Showmid,PEqmid)=>Chain(Peventmid)(Pmidw)accepted::(Showev)=>Int->Pevw->[[String]]accepted0_=[[]]acceptedd(Get(Justlow)(Justhigh)k)=dot<-accepted(d-1)(klow)leth=iflow==highthenshowlowelse(showlow++".."++showhigh)return(h:t)accepted_(GetNothingNothing_)=[["<any>"]]accepted_(GetNothing(Juste)_)=[[".."++showe]]accepted_(Get(Juste)Nothing_)=[[showe++".."]]accepted_Fail=[]accepted_(Write__)=[[]]-- this should show what action we get...acceptedd(Prior_p)=accepteddpacceptedd(Bestpq)=accepteddp++accepteddqaccepted_(End)=[]accepted_(Chain__)=error"accepted: chain not supported"-- ----------------------------------------------------------------------------- Operations over PrunWrite::PEqw=>Peventw->[event]->[w]runWrite_[]=[]runWritep(c:cs)=let(ws,p')=processOneEventpcinws++runWritep'csprocessOneEvent::PEqw=>Peventw->event->([w],Peventw)processOneEventpe=pullWrites$pushEventpe-- | Push an event in the automatonpushEvent::Pevw->ev->PevwpushEvent(Bestcd)e=Best(pushEventce)(pushEventde)pushEvent(Writewc)e=Writew(pushEventce)pushEvent(Priorpc)e=Priorp(pushEventce)pushEvent(Getlhf)e=iftest(e>=)l&&test(e<=)hthenfeelseFailwheretest=maybeTruepushEventFail_=FailpushEventEnd_=EndpushEvent(Chainpq)e=Chain(pushEventpe)q-- | Abstraction of the automaton state.dataInteractStateeventw=Ambiguous[(Int,w,Peventw)]|Waiting|Dead|Runningw(Peventw)instanceMonoid(InteractStateeventw)where-- not used at the moment:mappend(Runningwc)_=Runningwcmappend_(Runningwc)=Runningwc-- don't die if that can be avoidedmappendDeadp=pmappendpDead=p-- If a branch is not determined, wait for it.mappendWaiting_=Waitingmappend_Waiting=Waiting-- ambiguity remainsmappend(Ambiguousa)(Ambiguousb)=Ambiguous(a++b)mempty=Ambiguous[]-- | find all the writes that are accessible.findWrites::Int->Peventw->InteractStateeventwfindWritesp(Bestcd)=findWritespc`mappend`findWritespdfindWritesp(Writewc)=Ambiguous[(p,w,c)]findWritesp(Priordpc)=findWrites(p+dp)cfindWrites_Fail=DeadfindWrites_End=DeadfindWrites_(Get___)=WaitingfindWritesp(Chainab)=casecomputeStateaofDead->DeadAmbiguous_->Dead-- If ambiguity, don't try to do anything clever for now; die.Runningwc->findWritesp(Chainc(pushEventbw))-- pull as much as possible from the left automatonWaiting->casefindWritespbofAmbiguouschoices->Ambiguous[(p',w',Chainac')|(p',w',c')<-choices]Runningw'c'->Runningw'(Chainac')-- when it has nothing more, pull from the right.Dead->DeadWaiting->WaitingcomputeState::PEqw=>Peventw->InteractStateeventwcomputeStatea=casefindWrites0aofAmbiguousactions->letprior=minimum$mapfst3$actionsbests=groupBy(equiv`on`snd3)$filter((prior==).fst3)actionsincasebestsof[((_,w,c):_)]->Runningwc_->Ambiguous$mapheadbestss->spullWrites::PEqw=>Peventw->([w],Peventw)pullWritesa=casecomputeStateaofRunningwc->first(w:)(pullWritesc)_->([],a)instance(Showw,Showev)=>Show(Pevw)whereshow(GetNothingNothing_)="?"show(Get(Justl)(Justh)_p)|l==h=showl-- ++ " " ++ show (p l)show(Getlh_)=maybe""showl++".."++maybe""showhshow(Priorpc)=":"++showp++showcshow(Writewc)="!"++showw++"->"++showcshow(End)="."show(Fail)="*"show(Bestpq)="{"++showp++"|"++showq++"}"show(Chainab)=showa++">>>"++showb-- ----------------------------------------------------------------------------- Derived operationsoneOf::(Ordevent,MonadInteractmwevent)=>[event]->meventoneOfs=choice$mapeventsanyEvent::(Ordevent,MonadInteractmwevent)=>meventanyEvent=eventBoundsNothingNothingeventBetween::(Orde,MonadInteractmwe)=>e->e->meeventBetweenlh=eventBounds(Justl)(Justh)event::(Ordevent,MonadInteractmwevent)=>event->mevent-- ^ Parses and returns the specified character.evente=eventBetweeneeevents::(Ordevent,MonadInteractmwevent)=>[event]->m[event]-- ^ Parses and returns the specified list of events (lazily).events=mapMeventchoice::(MonadInteractmwe)=>[ma]->ma-- ^ Combines all parsers in the specified list.choice[]=fail"No choice succeeds"choice[p]=pchoice(p:ps)=p`mplus`choicepsoption::(MonadInteractmwe)=>a->ma->ma-- ^ @option x p@ will either parse @p@ or return @x@ without consuming-- any input.optionxp=p`mplus`returnx-- runProcess :: PEq w => I event w a -> [event] -> [w]-- -- ^ Converts a process into a function that maps input to output.-- -- The process does not hold to the input stream (no space leak) and-- -- produces the output as soon as possible.-- runProcess f = runWrite (mkF f)-- where mkF i = mkProcess i (const (Get (const Fail)))mkAutomaton::PEqw=>Ievwa->PevwmkAutomatoni=mkProcessi(constEnd)-- An automaton that produces its inputidAutomaton::(Orda,PEqa)=>PaaidAutomaton=GetNothingNothing$\e->WriteeidAutomaton-- It would be much nicer to write:-- mkAutomaton (forever 0 (anyEvent >>= write))-- however this creates a memory leak. Unfortunately I don't understand why.-- To witness:-- dist/build/yi/yi +RTS -hyI -hd-- Then type some characters. (Binds grows linearly)