{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}moduleCSPM.Evaluator.Expr(Evaluatable,eval,)whereimportControl.Monad.TransimportData.MaybeimportCSPM.DataStructures.LiteralsimportCSPM.DataStructures.NamesimportCSPM.DataStructures.SyntaximportCSPM.Evaluator.BuiltInFunctionsimportCSPM.Evaluator.DeclBindimportCSPM.Evaluator.EnvironmentimportCSPM.Evaluator.ExceptionsimportCSPM.Evaluator.MonadimportCSPM.Evaluator.PatBindimportCSPM.Evaluator.ValuesimportqualifiedCSPM.Evaluator.ValueSetasSimportUtil.AnnotatedimportUtil.ExceptionimportUtil.MonadimportUtil.PreludeimportUtil.PrettyPrint-- In order to keep lazy evaluation working properly only use pattern-- matching when you HAVE to know the value. (Hence why we delay pattern-- matching in BooleanBinaryOp And in case the first value is false.)classEvaluatableawhereeval::a->EvaluationMonadValueinstanceEvaluatablea=>Evaluatable(Annotatedba)whereeval(An__a)=evalainstanceEvaluatable(ExpName)whereeval(Appfuncargs)=dovs<-mapMevalargsVFunctionf<-evalfuncfvseval(BooleanBinaryOpope1e2)=dov1<-evale1v2<-evale2caseopofAnd->letVBoolb1=v1-- This is lazy, only pattern matches if b2 is required.VBoolb2=v2inreturn$VBool(b1&&b2)Or->letVBoolb1=v1-- This is lazy, only pattern matches if b2 is required.VBoolb2=v2inreturn$VBool(b1||b2)Equals->return$VBool(compareValuesv1v2==JustEQ)NotEquals->return$VBool(compareValuesv1v2/=JustEQ)LessThan->return$VBool(compareValuesv1v2==JustLT)GreaterThan->return$VBool(compareValuesv1v2==JustGT)LessThanEq->return$VBool(compareValuesv1v2`elem`[JustLT,JustEQ])GreaterThanEq->return$VBool(compareValuesv1v2`elem`[JustGT,JustEQ])eval(BooleanUnaryOpope)=doVBoolb<-evalecaseopofNot->return$VBool(notb)eval(Concate1e2)=doVListvs1<-evale1v2<-evale2-- If we instead wrote VList v2 <- eval e2-- then this would force evaluation of e2 to a list immediately.-- However, if we do the following instead this means that-- the second argument is only evaluated if it absolutely has to -- be (what if e2 was bottom and we were taking head(e1^e2)).-- (To see why haskell does this consider the desugared form with-- the do's removed. It would be:-- ... eval e1) >>= (\ (VList vs2) -> ...)-- and therefore the pattern match would force evaluation.)letVListvs2=v2return$VList(vs1++vs2)eval(DotAppe1e2)=dov1<-evale1v2<-evale2combineDotsv1v2eval(Ife1e2e3)=doVBoolb<-evale1ifbthenevale2elseevale3eval(Lambdape)=return$VFunction$\[v]->dolet(matches,binds)=bindpvifmatchesthenaddScopeAndBindbinds(evale)elsethrowError$patternMatchFailureMessage(locp)pveval(Letdeclse)=addScopeAndBindM(bindDeclsdecls)(evale)eval(Litlit)=return$caselitofInti->VIntiBoolb->VBoolbeval(Listes)=mapMevales>>=return.VListeval(ListCompesstmts)=doxs<-evalStmts(\(VListxs)->xs)stmts(mapMevales)return$VListxseval(ListEnumFrome)=doVIntlb<-evalereturn$VList(mapVInt[lb..])eval(ListEnumFromToe1e2)=doVIntlb<-evale1VIntub<-evale2return$VList(mapVInt[lb..ub])eval(ListLengthe)=doVListxs<-evalereturn$VInt(lengthxs)eval(MathsBinaryOpope1e2)=doVInti1<-evale1VInti2<-evale2caseopofDivide->return$VInt(i1`div`i2)Minus->return$VInt(i1-i2)Mod->return$VInt(i1`mod`i2)Plus->return$VInt(i1+i2)Times->return$VInt(i1*i2)eval(MathsUnaryOpope)=doVInti<-evalecaseopofNegate->return$VInt(-i)eval(Parene)=evaleeval(Setes)=mapMevales>>=return.VSet.S.fromListeval(SetCompesstmts)=doxs<-evalStmts(\(VSets)->S.toLists)stmts(mapMevales)return$VSet(S.fromListxs)eval(SetEnumes)=doevs<-mapMevalesss<-mapMcompleteEventevsreturn$VSet(S.unionsss)eval(SetEnumCompesstmts)=doss<-evalStmts(\(VSets)->S.toLists)stmts(mapM(\e->evale>>=completeEvent)es)return$VSet(S.unionsss)eval(SetEnumFrome)=doVIntlb<-evalereturn$VSet(S.IntSetFromlb)eval(SetEnumFromToe1e2)=doVIntlb<-evale1VIntub<-evale2return$VSet(S.fromList(mapVInt[lb..ub]))eval(Tuplees)=mapMevales>>=return.VTupleeval(Varn)|isNameDataConstructorn=doVTuple[dc,_,_]<-lookupVarnreturndceval(Varn)=dov<-lookupVarncasevofVProcp->return$VProc$PProcCall(procIdn[])p_->returnv-- This is the most complicated process because it is actually a shorthand-- for external choice and internal choice.eval(Prefixe1fse2)=letevalInputField::Value->[FieldName]->TCPat->S.ValueSet->(Value->[FieldName]->EvaluationMonadProc)->EvaluationMonad[Proc]evalInputFieldevBasefspsevalRest=domps<-mapM(\v->dolet(matches,binds)=bindpvifmatchesthendoev'<-combineDotsevBasevp<-addScopeAndBindbinds(evalRestev'fs)return$JustpelsereturnNothing)(S.toLists)return$catMaybesmps-- | Evalutates an input field, deducing the correct set of values-- to input over.evalInputField2::Value->[FieldName]->PatName->(Value->[FieldName]->EvaluationMonadProc)->([Proc]->Proc)->EvaluationMonadProcevalInputField2evBasefspevalRestprocConstructor=let-- | The function to use to generate the options. If this-- is the last field it uses 'extensions' to extend to a-- fully formed event, otherwise we use 'oneFieldExtensions'-- to extend by precisely one field.extensionsOperator=iffs==[]thenextensionselseoneFieldExtensions-- | Converts a pattern to its constituent fields.patToFields::PatName->[PatName]patToFields(PCompDotps_)=mapunAnnotatepspatToFields(PDoublePatternp1p2)=patToFields(unAnnotatep1)patToFieldsp=[p]-- | Given a value and a list of patterns (from -- 'patToFields') computes the appropriate set of events and-- then evaluates it.evExtensions::Value->[PatName]->EvaluationMonad[Proc]evExtensionsevBase[]=dop<-evalRestevBasefsreturn[p]evExtensionsevBase(PVarn:ps)|isNameDataConstructorn=doVTuple[dc,_,_]<-lookupVarnevBase'<-combineDotsevBasedcevExtensionsevBase'psevExtensionsevBase(p:ps)=dovs<-extensionsOperatorevBasemps<-mapM(\v->dolet(matches,bs)=bindpvifmatchesthendoevBase'<-combineDotsevBasevproc<-addScopeAndBindbs(evExtensionsevBase'ps)return$JustprocelsereturnNothing)vsreturn$concat$catMaybesmpsindops<-evExtensionsevBase(patToFieldsp)return$procConstructorpsevalNonDetFields::Value->[FieldName]->EvaluationMonadProcevalNonDetFieldsevBase(NonDetInputp(Juste):fs)=doVSets<-evaleps<-evalInputFieldevBasefspsevalNonDetFieldsreturn$PInternalChoicepsevalNonDetFieldsevBase(NonDetInputpNothing:fs)=evalInputField2evBasefs(unAnnotatep)evalNonDetFieldsPInternalChoiceevalNonDetFieldsevBasefs=evalFieldsevBasefsevalFields::Value->[FieldName]->EvaluationMonadProcevalFieldsev[]=do-- TODO: check valid eventp<-evalProce2return$PPrefix(valueEventToEventev)pevalFieldsevBase(Outpute:fs)=dov<-evaleev'<-combineDotsevBasevevalFieldsev'fsevalFieldsevBase(Inputp(Juste):fs)=doVSets<-evaleps<-evalInputFieldevBasefspsevalFieldsreturn$PExternalChoicepsevalFieldsevBase(InputpNothing:fs)=evalInputField2evBasefs(unAnnotatep)evalFieldsPExternalChoiceevalFieldsevBase(NonDetInput__:fs)=panic"Evaluation of $ after ! or ? is not supported."-- Takes a proc and combines nested [] and |~|simplify::Proc->Procsimplify(PExternalChoice[p])=simplifypsimplify(PInternalChoice[p])=simplifypsimplify(PExternalChoice(ps@((PExternalChoice_):_)))=letextract(PExternalChoiceps)=psinsimplify(PExternalChoice(concatMapextractps))simplify(PExternalChoiceps)=PExternalChoice(mapsimplifyps)simplify(PInternalChoice(ps@((PInternalChoice_):_)))=letextract(PInternalChoiceps)=psinsimplify(PInternalChoice(concatMapextractps))simplify(PInternalChoiceps)=PInternalChoice(mapsimplifyps)simplifyp=pindoev@(VDot(VChanneln:vfs))<-evale1VTuple[_,VIntarity,VListfieldSets]<-lookupVarnp<-evalNonDetFieldsev(mapunAnnotatefs)return$VProc(simplifyp)eval(AlphaParallele1e2e3e4)=dop1<-evalProce1p2<-evalProce4VSeta1<-evale2VSeta2<-evale3return$VProc$PAlphaParallel[(S.valueSetToEventSeta1,p1),(S.valueSetToEventSeta2,p2)]eval(Exceptione1e2e3)=dop1<-evalProce1VSeta<-evale2p2<-evalProce3return$VProc$PExceptionp1(S.valueSetToEventSeta)p2eval(ExternalChoicee1e2)=dop1<-evalProce1p2<-evalProce2return$VProc$PExternalChoice[p1,p2]eval(GenParallele1e2e3)=dops<-evalProcs[e1,e3]VSeta<-evale2return$VProc$PGenParallel(S.valueSetToEventSeta)pseval(GuardedExpguardproc)=doVBoolb<-evalguardifbthenevalprocelselookupVar(builtInName"STOP")eval(Hidinge1e2)=dop<-evalProce1VSets<-evale2return$VProc$PHidep(S.valueSetToEventSets)eval(InternalChoicee1e2)=dops<-evalProcs[e1,e2]return$VProc$PInternalChoicepseval(Interrupte1e2)=dop1<-evalProce1p2<-evalProce2return$VProc$PInterruptp1p2eval(Interleavee1e2)=dops<-evalProcs[e1,e2]return$VProc$PInterleavepseval(LinkParallele1tiesstmtse2)=dop1<-evalProce1p2<-evalProce2ts<-evalTiesstmtstiesreturn$VProc$PLinkParallelp1tsp2eval(Renamee1tiesstmts)=dop1<-evalProce1ts<-evalTiesstmtstiesreturn$VProc$PRenametsp1eval(SequentialCompe1e2)=dop1<-evalProce1p2<-evalProce2return$VProc$PSequentialCompp1p2eval(SlidingChoicee1e2)=dop1<-evalProce1p2<-evalProce2return$VProc$PSlidingChoicep1p2eval(ReplicatedAlphaParallelstmtse1e2)=doaps<-evalStmts(\(VSets)->S.toLists)stmts(doVSets<-evale1p<-evalProce2return[(S.valueSetToEventSets,p)])return$VProc$PAlphaParallelapseval(ReplicatedExternalChoicestmtse)=dops<-evalStmts(\(VSets)->S.toLists)stmts(evalProcs[e])return$VProc$PExternalChoicepseval(ReplicatedInterleavestmtse)=dops<-evalStmts(\(VSets)->S.toLists)stmts(evalProcs[e])return$VProc$PInterleavepseval(ReplicatedInternalChoicestmtse)=dops<-evalStmts(\(VSets)->S.toLists)stmts(evalProcs[e])lete'=ReplicatedInternalChoicestmtsecasepsof[]->throwError$replicatedInternalChoiceOverEmptySetMessage(loce)e'_->return$VProc$PInternalChoicepseval(ReplicatedLinkParalleltiestiesStmtsstmtse)=dotsps<-evalStmts(\(VListvs)->vs)stmts$dots<-evalTiestiesStmtstiesp<-evalProcereturn[(ts,p)]letmkLinkPar[(ts,p1)]=p1mkLinkPar((ts,p1):tps)=PLinkParallelp1ts(mkLinkPartps)return$VProc$mkLinkPartspseval(ReplicatedParallele1stmtse2)=doVSets<-evale1ps<-evalStmts(\(VSets)->S.toLists)stmts(evalProcs[e2])return$VProc$PGenParallel(S.valueSetToEventSets)psevale=panic("No clause to eval "++showe)evalProcs::Evaluatablea=>[a]->EvaluationMonad[Proc]evalProcsas=mapMevalProcasevalProc::Evaluatablea=>a->EvaluationMonadProcevalProca=evala>>=\v->casevofVProcx->returnx_->panic"Type checker error"evalTies::[TCStmt]->[(TCExp,TCExp)]->EvaluationMonad[(Event,Event)]evalTiesstmtsties=dotss<-evalStmts(\(VSets)->S.toLists)stmts(mapMevalTieties)return$concattsswhereextendTie::(Value,Value)->Value->EvaluationMonad(Event,Event)extendTie(evOld,evNew)ex=doev1<-extendEventevOldexev2<-extendEventevNewexreturn(valueEventToEventev1,valueEventToEventev2)evalTie(eOld,eNew)=doevOld<-evaleOldevNew<-evaleNew-- Obviously evOld and evNew could be channels, or prefixes-- of events so we compute the extensions.-- TODO: this assumes extensions evOld <= extensions evNewexsOld<-extensionsevOldmapM(\ex->extendTie(evOld,evNew)ex)exsOld-- | Evaluates the statements, evaluating `prog` for each possible -- assingment to the generators that satisfies the qualifiers.evalStmts::(Value->[Value])->[TCStmt]->EvaluationMonad[a]->EvaluationMonad[a]evalStmtsextractanStmtsprog=let-- | Progressively generates new values lazilyevStmts[]=progevStmts(Qualifiere:stmts)=doVBoolb<-evaleifbthenevStmtsstmtselsereturn[]evStmts(Generatorpe:stmts)=dov<-evalevss<-mapM(\v->dolet(matches,binds)=bindpvifmatchesthenaddScopeAndBindbinds(evStmtsstmts)elsereturn[])(extractv)return$concatvssinevStmts(mapunAnnotateanStmts)-- | Takes a VEvent and then computes all events that this is a prefix of.completeEvent::Value->EvaluationMonadS.ValueSetcompleteEventev=doexs<-extensionsevl<-mapM(extendEventev)exsreturn$S.fromListlextendEvent::Value->Value->EvaluationMonadValueextendEventevexs=combineDotsevexs